Compare commits

..

12 Commits

Author SHA1 Message Date
d884ca4179 simplify comments
CI / Test + coverage (push) Successful in 1m1s
2026-09-23 03:21:23 -09:00
2637b69c2c proomptin'
CI / Test + coverage (push) Successful in 58s
2026-09-22 11:49:16 -09:00
a6f49938dc fiddle
CI / Test + coverage (push) Successful in 1m20s
2026-09-22 10:52:29 -09:00
2d606d0620 get agent to use current state
CI / Test + coverage (push) Successful in 57s
2026-09-22 06:24:04 -09:00
a7f12b5d72 migrate to AG-UI state sync
CI / Test + coverage (push) Successful in 1m4s
2026-09-22 06:07:45 -09:00
6569a69463 Merge pull request 'framework-ify. proper agent runtime + adopt ag-ui' (#1) from ag-ui into main
CI / Test + coverage (push) Successful in 59s
Reviewed-on: #1
2026-09-21 18:57:04 -09:00
a3ef6ec077 framework-ify. proper agent runtime + adopt ag-ui
CI / Test + coverage (pull_request) Successful in 1m41s
2026-09-21 18:34:19 -09:00
187252177c merge db sources
CI / Test + coverage (push) Successful in 46s
2026-09-21 14:11:00 -09:00
bf38f7b1be scope tools by page
CI / Test + coverage (push) Successful in 3m34s
2026-09-21 14:01:34 -09:00
a53f0c3621 add integrated chatbot with streaming + tools
CI / Test + coverage (push) Successful in 1m23s
2026-09-21 09:09:55 -09:00
10f4ca654b set up pages in UI
CI / Test + coverage (push) Successful in 1m9s
2026-09-21 06:20:30 -09:00
47f6cbf2d1 add ui tests to ci
CI / Test + coverage (push) Successful in 1m33s
2026-09-19 19:17:22 -09:00
79 changed files with 9735 additions and 540 deletions
+3 -3
View File
@@ -1,8 +1,8 @@
target
**/target
.cpcache
.git
node_modules
.shadow-cljs
**/node_modules
**/.shadow-cljs
resources/public/js
.env
data
+26 -9
View File
@@ -25,16 +25,33 @@ SESSION_SECRET=
# Empty = nobody can.
ADMIN_USERS=
# --- Todo database --------------------------------------------------------
# SQLite file for the todo group; the directory is created on first use. In Docker, mount a
# volume here or the todos vanish with the container.
# TODO_DB_PATH=data/todo.db
# --- Database -----------------------------------------------------------------
# The one SQLite file the app keeps everything in: the todos, and the MCP server's OAuth state
# (registered clients, and the hashed tokens of every client a user has approved). The directory
# is created on first use. In Docker, mount a volume here or the todos vanish with the container
# and every MCP client has to be approved again after a restart. BASE_URL (above) must be the
# address MCP clients use.
# DB_PATH=data/tbd.db
# --- MCP OAuth database -----------------------------------------------------
# SQLite file for the MCP server's OAuth state: registered clients, and the tokens (hashed)
# of every client a user has approved. In Docker, mount a volume here too, or every MCP client
# has to be approved again after a restart. BASE_URL (above) must be the address MCP clients use.
# OAUTH_DB_PATH=data/oauth.db
# --- Agent (LM Studio, via LangChain4j) ---------------------------------------
# The agent (tbd.agent.core, a LangChain4j streaming chat model) talks to an LM Studio server.
# Two surfaces use it: the chat widget in the UI (the green square, bottom left; POST /api/chat, an
# AG-UI run, logged-in users only) and the A2A server for other agents (POST /a2a, the same OAuth
# access token as /mcp; see /.well-known/agent-card.json). Point it at your LM Studio instance:
# server address, no /v1 (start its server, and enable "Serve on Local Network" for a remote one).
# Unset LMSTUDIO_URL = both surfaces answer "not configured".
# LMSTUDIO_URL=http://192.168.1.20:1234
# Model id to ask for; empty = whichever model LM Studio has loaded.
# LMSTUDIO_MODEL=
# Only if the server requires an API key.
# LMSTUDIO_API_KEY=
# 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 turn (chat or A2A) is summarised in the server's log. To also keep the model's full
# reasoning and replies, and the messages it was sent (for finding out why it loops), append a JSON
# trace to this file. It holds what users typed, so keep it private.
# CHAT_TRACE_FILE=data/chat-trace.jsonl
# --- WebMCP origin trial ------------------------------------------------------
# Chrome's WebMCP (the UI's browser tools) is in an origin trial. Register BASE_URL's origin at
+6 -2
View File
@@ -24,8 +24,12 @@ jobs:
docker compose version
docker buildx version
# Each suite runs once, under Cloverage; the merged report is the dockerized
# equivalent of script/coverage.
# Each suite runs once, under a coverage tool. The Clojure reports (Cloverage) are merged
# below; the UI's (c8) stands on its own. Together this is the dockerized equivalent of
# script/coverage.
- name: UI tests (coverage)
run: script/docker-ui-coverage
- name: Unit tests (coverage)
run: script/docker-unit-coverage
+1 -1
View File
@@ -8,7 +8,7 @@ resources/public/js
# clj-kondo / clojure-lsp caches
.clj-kondo
.lsp
# Local SQLite databases (TODO_DB_PATH, OAUTH_DB_PATH)
# Local SQLite database (DB_PATH)
data
# Local secrets (copy .env-template to .env)
.env
+15 -1
View File
@@ -2,7 +2,8 @@
# to ../resources/public/js (see ui/shadow-cljs.edn), i.e. /build/resources/public/js here.
# trixie, not bookworm: its default-jre is Java 21, which shadow-cljs's Closure Compiler
# requires (bookworm's is 17 -> UnsupportedClassVersionError).
FROM node:22-trixie-slim AS ui
# ui-base holds what the UI's release build and its tests share: the toolchain and the deps.
FROM node:22-trixie-slim AS ui-base
RUN apt-get update \
&& apt-get install -y --no-install-recommends default-jre-headless \
@@ -14,9 +15,22 @@ RUN npm ci
# Resolve the ClojureScript deps in their own layer so source edits don't re-download them.
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
# The UI's tests, not part of the server image: `docker build --target ui-test`
# (script/docker-ui-test, script/docker-ui-coverage). Running the container runs the tests;
# `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"]
# Stage 2: the server.
# JDK 21+ is required by the MCP server (plumcp runs on virtual threads).
FROM clojure:temurin-21-tools-deps
+251 -32
View File
@@ -8,7 +8,7 @@ dockerized integration tests, and joint line coverage.
## Requirements
- Docker, for the integration tests and the `script/docker-*` tasks (all CI needs)
- For running tasks natively (optional): [Clojure CLI](https://clojure.org/guides/install_clojure) (tools.deps) with JDK 21+, [Node](https://nodejs.org/) 20+ (with a JDK) for the UI build, and [Babashka](https://babashka.org/) for `script/coverage-report`
- For running tasks natively (optional): [Clojure CLI](https://clojure.org/guides/install_clojure) (tools.deps) with JDK 21+, [Node](https://nodejs.org/) 20+ (22.22+ for the UI tests; with a JDK) for the UI build, and [Babashka](https://babashka.org/) for `script/coverage-report`
## Running
@@ -48,13 +48,16 @@ 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.** An [AG-UI](https://docs.ag-ui.com) run: body a `RunAgentInput` (`{"messages": [{"id": "m1", "role": "user", "content": "hi"}], ...}`, the conversation so far, 1 to 40 messages of up to 8000 characters, roles `user`, `assistant` or `tool`; optionally `"tools"`, the page's tools as AG-UI describes them: see [the chatbot's tools](#the-chatbots-tools), and `"context"`, ambient information for the run — the id of the UI page the user is on travels as `{"description": "page", "value": "tic-tac-toe"}`) sends it to the [chatbot's](#chatbot) agent and **streams the reply back** as AG-UI server-sent events (`text/event-stream`): `RUN_STARTED`, then `TEXT_MESSAGE_START`/`TEXT_MESSAGE_CONTENT`/`TEXT_MESSAGE_END` for the reply, `REASONING_MESSAGE_START`/`_CONTENT`/`_END` for the model's reasoning, `TOOL_CALL_START`/`_ARGS`/`_END` if it asks for tools to be called, and last `RUN_FINISHED` or `RUN_ERROR`. Failures before the run starts are ordinary errors: 400 for an invalid input, 502 if the LLM server can't be reached or refuses, 503 if `LMSTUDIO_URL` isn't set |
| `POST` | `/a2a` | The [A2A server](#a2a-server): JSON-RPC 2.0, `message/send` only (no streaming; see below). **Needs an OAuth access token**, the same one an MCP client uses (`401` without one) |
| `GET` | `/.well-known/agent-card.json` | The A2A server's [AgentCard](https://a2a-protocol.org): its name, url, capabilities and skills |
| `GET` | `/api-docs` | Swagger UI |
| `GET` | `/swagger.json` | OpenAPI/Swagger spec |
| `GET` | `/auth/login` | Starts the Gitea OAuth login (redirects to Gitea) |
| `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) |
@@ -89,10 +92,16 @@ and the [MCP tools](#mcp-server) both call, so they behave the same and are test
tool only translates its request into a service call and the result into a response, and never
touches the database.
Todos are stored in a local [SQLite](https://www.sqlite.org/) file, `data/todo.db` by default
(git-ignored), which is created and migrated on the first todo request. Set `TODO_DB_PATH` to put it
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.
Everything the app stores (todos, and the MCP OAuth state) lives in one local
[SQLite](https://www.sqlite.org/) file, `data/tbd.db` by default (git-ignored), which is created and
migrated on first use. Each group owns its own tables (`tbd.todo.db`, `tbd.oauth.db`); `tbd.sqlite` opens the
file and runs their migrations. Set `DB_PATH` to put it elsewhere. In Docker, mount a volume at that path
(e.g. `docker run -v tbd-data:/app/data ...`), or the todos and MCP approvals 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:
@@ -158,12 +167,38 @@ The consent page is what stops a stranger's client (anyone can register one) fro
sending you a link: nothing is issued without your click. Redirect URIs must be `https`, `http` on
`localhost`/`127.0.0.1`/`[::1]` (the port may vary), or an app's own scheme (`cursor://...`).
What's stored is in `OAUTH_DB_PATH`: registered clients, and for each approval the user and a *hash* of the
What's stored is in the app's database (`DB_PATH`): registered clients, and for each approval the user and a *hash* of the
current access and refresh tokens. To cut a client off, delete its row from `grants`. Admin-ness isn't in
the token: it is looked up in `ADMIN_USERS` on every request, so removing someone from the list takes
effect at once. A Gitea account that is disabled keeps working until its refresh token expires (up to 30
days without use) or its grant is deleted, since Gitea isn't asked again after the login.
## A2A server
The server also speaks [A2A](https://a2a-protocol.org) (Agent2Agent) at `/a2a`, for other agents
(Claude Code, Codex, ...) to call directly, the way `/mcp` lets an MCP client call its tools. It's a
second face of the same agent as the chatbot (`tbd.agent.core`), but not tied to a browser page: an
A2A caller has no page open, so `tbd.agent.a2a` gives it the app's *server-side* tools instead —
todo CRUD and math, the same operations `tbd.mcp.tools` exposes to MCP clients, defined again over
`tbd.todo.service`/`tbd.math.core` directly (this ns doesn't depend on plumcp). Its system prompt
(`tbd.agent.instructions/a2a`) is framed for a caller with no page and no visual feedback, not the
chatbot's in-page persona.
```bash
curl https://tbd.example.com/.well-known/agent-card.json # <BASE_URL>/a2a, its capabilities and skills
curl -H "Authorization: Bearer $TOKEN" -H 'Content-Type: application/json' \
-d '{"jsonrpc":"2.0","id":1,"method":"message/send","params":{"message":{"role":"user","kind":"message","messageId":"m1","parts":[{"kind":"text","text":"list my todos"}]}}}' \
https://tbd.example.com/a2a
```
`$TOKEN` is the same OAuth access token an MCP client gets ([above](#connecting-an-mcp-client)):
`wrap-bearer-auth` verifies a token by looking it up, not by which `resource` it names, so a token
minted for `/mcp` works here too. Only `message/send` is implemented — the AgentCard says so
(`capabilities.streaming: false`) — so a call is synchronous: if the agent asks for a tool, this ns
runs it itself immediately (server-side, no browser to hand it to) and asks the agent again, up to 8
rounds, until it answers in text, which comes back as the JSON-RPC result (an A2A `Message`, role
`"agent"`). Streaming for a browser-driven conversation is what [AG-UI](#chatbot) is for.
## Authentication and the admin API
Login is OAuth2 (authorization-code flow) against a [Gitea](https://about.gitea.com/) instance.
@@ -179,11 +214,12 @@ login, **403** for a logged-in non-admin. With no allowlist, nobody is an admin.
| Variable | Purpose |
|----------|---------|
| `GITEA_URL`, `GITEA_CLIENT_ID`, `GITEA_CLIENT_SECRET` | The Gitea OAuth2 application. Without all three (and `BASE_URL`), `/auth/login` answers 503 |
| `BASE_URL` | Public URL of this app; an `https://` one also marks the session cookie `Secure`. It is also the address of the MCP server: the OAuth issuer, and what MCP clients are told to use (`<BASE_URL>/mcp`) |
| `BASE_URL` | Public URL of this app; an `https://` one also marks the session cookie `Secure`. It is also the address of the MCP and A2A servers: the OAuth issuer, what MCP clients are told to use (`<BASE_URL>/mcp`), and the A2A AgentCard's `url` (`<BASE_URL>/a2a`) |
| `ADMIN_USERS` | Comma-separated Gitea usernames (case-insensitive) allowed to use the admin API |
| `SESSION_SECRET` | Signs and encrypts session cookies. Unset = a random key per start, so logins don't survive a restart |
| `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 |
| `DB_PATH` | The app's SQLite file: todos, and the MCP OAuth server's registered clients, codes and tokens (default `data/tbd.db`). Mount a volume for it in Docker, or todos are lost and every MCP client has to be approved again after each restart |
| `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
@@ -209,12 +245,20 @@ 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's a small calculator form that calls `GET /api/add` and shows the sum (or the server's
validation error). Below it, once you're logged in, is a todo list (add, tick off, delete) backed by
`/api/todos`; it stays hidden when you're not. At the bottom is a section with 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. A "Log in" / "Log out" link sits in the footer row
next to the API docs links.
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 |
|-----|--------------|
| 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) |
A "Log in" / "Log out" link sits in the footer row next to the API docs links.
A green square in the bottom left corner (on every page, opposite the blue WebMCP one) opens the
[chatbot](#chatbot).
shadow-cljs compiles it into `resources/public/js/` (git-ignored). The server serves that
directory at `/js`, and serves `resources/public/index.html`, the shell that mounts the app, at `/`.
@@ -224,30 +268,189 @@ directory at `/js`, and serves `resources/public/index.html`, the shell that mou
| `script/ui-build` | Optimized release build into `resources/public/js` |
| `script/ui-watch` | Rebuilds on every change, with hot reload; run `script/server` alongside and refresh the page |
The Docker image builds the UI in its own stage, so `docker build` needs no local Node.
The Docker image builds the UI in its own stage, so `docker build` needs no local Node. The UI's tests run
in another stage of the same Dockerfile (`--target ui-test`), which the server image doesn't include.
### Chatbot
The green square opens a small chat panel. What you type goes to `POST /api/chat`, an
[AG-UI](https://docs.ag-ui.com) run; the backend's agent (`tbd.agent.core`, a
[LangChain4j](https://docs.langchain4j.dev/) streaming chat model) forwards the conversation to an
[LM Studio](https://lmstudio.ai) server (its OpenAI-compatible `/v1/chat/completions`) and streams
the reply back as AG-UI events. The browser never talks to the LLM directly, so the server's address
(and key) stay on the backend. The panel shows "Thinking…" until the model's first word (a reasoning
model can take a while), then the reply appears as it is generated. What the model reasons is never
shown, only that it is thinking; the tool calls (see below) show as small grey lines between the
replies, in full, however long, and the conversation scrolls. The conversation lives in the page only
(a reload or logging out clears it), and the UI sends the last 40 messages of it. Chat needs a login,
like the todos: every message costs the LLM server's time.
The conversation scrolls. It follows the reply while you are at its end; scroll up to read back and it
stays put until you send a message or scroll down again. Drag the panel's top right corner to make it
wider or taller (the size is kept while the page is open, through Clear and closing the panel).
`curl -N` shows the stream (`-N` turns off curl's own buffering; use your session cookie):
```bash
curl -N -H "Cookie: $COOKIE" -H 'Content-Type: application/json' \
-d '{"messages":[{"id":"m1","role":"user","content":"hi"}]}' http://localhost:3000/api/chat
```
#### The chatbot's tools
The chatbot can use the page. The [browser tools](#browser-mcp-tools-webmcp) (the calculator, the todos,
tic-tac-toe) are registered in the page's *model context*, `ui/src/tbd/ui/model_context.cljs`, which is
what WebMCP's `navigator.modelContext` is to an agent outside the page. The chat is that agent, embedded,
and this is exactly the shape of AG-UI's **frontend tools**: the agent asks, the browser runs them.
1. Each `POST /api/chat` carries `"tools"`, the ones the page currently offers, as AG-UI describes them
(`{"name", "description", "parameters"}`, the schema being JSON Schema), and `"context"` naming the
page (`{"description": "page", "value": "tic-tac-toe"}`). The backend converts them to LangChain4j's
typed tool specifications for the LLM, and stays stateless. Only the tools of the page being shown are
listed: a tool registered with `:pages #{:calculator}` is offered on the Calculator page and nowhere
else (tic-tac-toe's tools are the Tic-tac-toe page's, the todos' are the Todos page's), and one with no
`:pages` (`ping`, `whoami`, `navigate`) on every page. The list follows the page the user is on each
time the conversation is sent (so does the page's name, which the backend's agent puts in the system
message ahead of the conversation, with the names of the tools it has), and a call for a tool the page
doesn't offer is refused with an error the LLM reads. The LLM can move between pages with `navigate`;
its next request then carries the new page and that page's tools. An agent outside the page, through
WebMCP, is still offered all of them.
2. The LLM never runs anything. When it wants a tool, it says so: the reply ends with
`TOOL_CALL_START`/`TOOL_CALL_ARGS`/`TOOL_CALL_END` events, one triple per call (`TOOL_CALL_ARGS`'s
`delta` being the JSON text the model wrote). The backend only relays them.
3. The page intercepts them and calls the tools right there (one after the other), through the same
handlers WebMCP uses, so they act on the page as a user would and you see it happen. The chat panel
shows each call and its result in small print between the messages.
4. The results go back as messages with the role `tool` (`{"role": "tool", "toolCallId": "call_1",
"content": "..."}`, after the assistant message that asked, which carries `"toolCalls"`), in
another request with the conversation so far, for the LLM to go on from, until it answers with words.
A call that can't be made (a tool that isn't there, arguments that aren't a JSON object, a tool that
fails) is a result with the reason, for the model to read and try again from. To keep a model that never
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: its system prompt
(`tbd.agent.instructions/chat`, in `src/tbd/agent/instructions.clj` — a JVM-only namespace, never on the
UI's classpath, so the chatbot's own instructions are never bundled into the browser) says that what it
does shows on your screen at once, so it should call a tool in the same turn rather than offer to, chain
calls (navigate, list, then act), take obvious defaults instead of asking, and answer in one short
sentence, since the call and its result are already shown. It reuses the wording that genuinely is shared
with an outside agent (`act`, `work-it-out`, `tic-tac-toe-rules`, `examples`) from `tbd.agent.prompt` (the
shared `.cljc`, [see below](#browser-mcp-tools-webmcp)) rather than duplicating it. If a model still
answers requests with offers, that's what to tune for it; the tool descriptions in `webmcp.cljs` are the
other lever.
To try it, use a model that supports tool use in LM Studio, log in, and ask the chat something the page
can do: *"add 2 and 3 with the calculator"*, *"add a todo to buy milk"*, *"play tic-tac-toe with me, you're O"*.
A reverse proxy in front of tbd must not buffer responses, or the reply arrives all at once at the end
(the server sends `X-Accel-Buffering: no`, which nginx obeys; for others, turn buffering off for `/api/chat`).
The `REASONING_MESSAGE_CONTENT` events also keep the connection from looking idle to a proxy while the model reasons; the UI drops their text, only using them to show "Thinking…".
Anything that goes wrong is logged on the server's stdout, with a `[tbd] chat:` prefix.
Point the backend at your instance with environment variables (see [.env-template](.env-template)):
```bash
LMSTUDIO_URL=http://192.168.1.20:1234 script/server
```
Only `LMSTUDIO_URL` is required (the address of LM Studio's server, without `/v1`; for a remote instance
turn on "Serve on Local Network" there). `LMSTUDIO_MODEL` picks a model by id (default: the one LM Studio
has loaded), `LMSTUDIO_API_KEY` is sent as a bearer token if the server wants one, and
`LMSTUDIO_TIMEOUT_SECONDS` (default 120) is how long the LLM server may stay silent, before it starts
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. 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 (`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`
@@ -271,23 +474,35 @@ script/repl
| Task | What it does |
|------|--------------|
| `script/unit-test` | Runs the Clojure tests in `test/` |
| `script/ui-test` | Runs the ClojureScript tests in `ui/test/` under Node (needs Node and a JDK; CI doesn't run it yet) |
| `script/ui-test` | Runs the ClojureScript tests in `ui/test/` under Node, in a [jsdom](https://github.com/jsdom/jsdom) window (needs Node and a JDK) |
| `script/integration-test` | Builds the app image, starts it on a random port, runs the [integration suite](integration-test/README.md) against it, then tears it down |
| `script/test` | Unit tests, then integration tests (stops at the first failure) |
| `script/test` | UI tests, unit tests, then integration tests (stops at the first failure) |
| `script/docker-unit-test` | Same as `script/unit-test`, but inside the app image (Docker only) |
| `script/docker-ui-test` | Same as `script/ui-test`, but inside a Node + JDK image (Docker only) |
The UI tests render the real app in jsdom against a fake server and drive it like a user (type, submit,
click), next to plain tests of the re-frame events and subscriptions, the game rules and the WebMCP tools
(`ui/test/tbd/ui/`; the shared fakes are in `test_util.cljs`). `ui/test/dom-setup.cjs` gives them a
`window` and the real WebMCP library, and fails a run that hangs, rejects a promise nobody handles, or ends
without a result (a test that never calls `done` would otherwise pass or stall silently). `npm test` in
`ui/` preloads it, so use that (or the scripts) rather than running the build's output directly.
### Coverage
Line coverage via [Cloverage](https://github.com/cloverage/cloverage):
Line coverage of the Clojure code via [Cloverage](https://github.com/cloverage/cloverage), and of the UI via
[c8](https://github.com/bcoe/c8):
| Task | Output |
|------|--------|
| `script/unit-coverage` | `target/coverage/unit/` |
| `script/integration-coverage` | `target/coverage/integration/` |
| `script/coverage` | Runs both, then writes the merged report to `target/coverage/merged/` |
| `script/docker-unit-coverage`, `script/docker-coverage-report` | Dockerized versions of the unit run and the merge step, so `script/docker-unit-coverage`, `script/integration-coverage`, `script/docker-coverage-report` is `script/coverage` with no local Clojure or Babashka (this is what CI runs) |
| `script/ui-coverage` | `target/coverage/ui/` (V8 coverage of the compiled UI, mapped back to `ui/src/**/*.cljs` through the source maps) |
| `script/coverage` | Runs all three, then writes the merged Clojure report to `target/coverage/merged/` (the UI's stays separate) |
| `script/docker-unit-coverage`, `script/docker-ui-coverage`, `script/docker-coverage-report` | Dockerized versions of the unit run, the UI run and the merge step, so `script/docker-ui-coverage`, `script/docker-unit-coverage`, `script/integration-coverage`, `script/docker-coverage-report` is `script/coverage` with no local Clojure, Node or Babashka (this is what CI runs) |
Each report directory has an `index.html` and an `lcov.info`. See
Each report directory has an `index.html` and an `lcov.info`. The UI's numbers are approximate where one
ClojureScript form compiles to several JavaScript blocks (a `case` or `cond`, say): a line can show as
uncovered when only part of the form ran. See
[integration-test/README.md](integration-test/README.md) for how integration coverage is
collected.
@@ -302,19 +517,23 @@ src/tbd/
<group>/schema.clj Malli schemas of the group's input, shared by its routes and the MCP tools
auth/ Gitea OAuth (core), session + admin middleware (middleware), /auth routes
mcp/ MCP server (PluMCP) mounted at `/mcp`: tools (tools.clj), Malli-to-tool glue (schema.clj) and the Ring handler (routes.clj)
oauth/ tbd as the OAuth authorization server for MCP clients: rules (core), SQLite storage (db), `/oauth` + discovery routes, and the bearer-token middleware guarding `/mcp` (middleware)
oauth/ tbd as the OAuth authorization server for MCP and A2A clients: rules (core), SQLite storage (db), `/oauth` + discovery routes, and the bearer-token middleware guarding `/mcp` and `/a2a` (middleware)
agent/ The agent: a LangChain4j streaming chat model (core), JSON-Schema translation for tool specs (json_schema), its system prompts (instructions), and the A2A server mounted at `/a2a` (a2a)
chat/ /api/chat: the AG-UI wire protocol (routes), the request's Malli schema (schema), per-turn logging and loop detection (trace) — the agent itself is agent/core.clj
nrepl/ On-demand nREPL server (core) and the admin-only `/nrepl` routes
todo/ Per-user todos: pure rules (core), Malli schemas of the input (schema), SQLite storage (db), `/api/todos` routes
ui/ ClojureScript re-frame app (shadow-cljs project); ui/src/tbd/ui/{db,events,subs,views,webmcp,core}.cljs, tests in ui/test/
shared/ .cljc read by both the server and the UI (tbd.agent.prompt: the instructions an outside agent, through WebMCP, is given — the chatbot's own system prompt is server-only, in src/tbd/agent/instructions.clj)
ui/ ClojureScript re-frame app (shadow-cljs project); ui/src/tbd/ui/{db,events,subs,views,webmcp,model_context,core}.cljs, tests in ui/test/
.env-template Settings the server reads from the environment; copy to .env (git-ignored)
resources/public/ index.html (the shell served at /) and js/ (compiled UI output, git-ignored)
test/ Unit tests
integration-test/ Dockerized integration tests and coverage harness
script/ Bash entry points (server, ui-build, test, coverage, repl, ...) and coverage helpers
script/ Bash entry points (server, ui-build, ui-test, test, coverage, repl, ...) and coverage helpers
```
To add a new group, create `tbd.<group>.routes` with a `routes` fn that returns a reitit route
vector, then add it to the router in `src/tbd/core.clj`. To make a route admin-only, put
`:admin? true` in its route data (admin allowlist), or `:login? true` (any logged-in user; the user is
passed to the handler as `:user`). A group with storage keeps it in its own `tbd.<group>.db`, apart
from its business logic in `core.clj`.
from its business logic in `core.clj`, with a `migrate!` fn for its tables in the app's one database;
add it to the `sqlite/open` call in `make-router`.
+6 -2
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"}
@@ -12,7 +12,11 @@
;; The MCP server, mounted at /mcp (see tbd.mcp.routes). Needs JDK 21+ (virtual threads).
;; plumcp needs exactly one JSON module; jsonista is already on the classpath via muuntaja.
io.github.plumce/plumcp.core {:mvn/version "0.3.0-beta2"}
io.github.plumce/plumcp.core-json-jsonista {:mvn/version "0.3.0-beta2"}}
io.github.plumce/plumcp.core-json-jsonista {:mvn/version "0.3.0-beta2"}
;; The agent (see tbd.agent.core): a LangChain4j streaming chat model talking to LM Studio's
;; OpenAI-compatible server. Plain libraries, no Spring/Quarkus runtime pulled in.
dev.langchain4j/langchain4j {:mvn/version "1.20.0"}
dev.langchain4j/langchain4j-open-ai {:mvn/version "1.20.0"}}
:aliases
{:dev
+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")
+3 -2
View File
@@ -1,9 +1,10 @@
#!/usr/bin/env bash
# Run the full suite (unit + integration) with line coverage and write the joint
# report to target/coverage/merged.
# Run the full suite (UI + unit + integration) with line coverage. The Clojure suites'
# joint report goes to target/coverage/merged; the UI's is separate (target/coverage/ui).
set -euo pipefail
cd "$(dirname "$0")/.."
script/ui-coverage
script/unit-coverage
script/integration-coverage
script/coverage-report
+20
View File
@@ -0,0 +1,20 @@
#!/usr/bin/env bash
# Run the UI's tests under c8 inside a Node + JDK image; needs only Docker. The report is
# copied out with `docker cp` (not a bind mount) so it works when this itself runs in a
# job container. Output: target/coverage/ui.
set -euo pipefail
cd "$(dirname "$0")/.."
source script/lib/docker.sh
build_ui_test_image
id=$(docker create --security-opt apparmor=unconfined tbd-ui-test npm run coverage)
trap 'docker rm -f "$id" >/dev/null' EXIT
status=0
docker start -a "$id" || status=$?
rm -rf target/coverage/ui
mkdir -p target/coverage
docker cp "$id:/build/target/coverage/ui" target/coverage/ || echo "[test] WARNING: no UI coverage report was produced"
exit "$status"
+8
View File
@@ -0,0 +1,8 @@
#!/usr/bin/env bash
# Run the UI's (ClojureScript) tests inside a Node + JDK image; needs only Docker.
set -euo pipefail
cd "$(dirname "$0")/.."
source script/lib/docker.sh
build_ui_test_image
exec docker run --rm --security-opt apparmor=unconfined tbd-ui-test
+6
View File
@@ -18,3 +18,9 @@ build_unit_image() {
use_builder
docker buildx build --load --build-arg DEPS_ALIASES=test:cov -t tbd-unit .
}
# Builds the UI's test image (Node + JDK, the UI's deps, sources and tests), tagged tbd-ui-test.
build_ui_test_image() {
use_builder
docker buildx build --load --target ui-test -t tbd-ui-test .
}
+2 -1
View File
@@ -1,7 +1,8 @@
#!/usr/bin/env bash
# Run the unit tests, then the integration tests (stops at the first failure).
# Run the UI tests, the unit tests, then the integration tests (stops at the first failure).
set -euo pipefail
cd "$(dirname "$0")/.."
script/ui-test
script/unit-test
script/integration-test
+8
View File
@@ -0,0 +1,8 @@
#!/usr/bin/env bash
# Run the UI's tests with line coverage (c8, mapped back to the ClojureScript); the report goes
# to target/coverage/ui. Needs Node and a JDK, like script/ui-test.
set -euo pipefail
cd "$(dirname "$0")/../ui"
[[ -d node_modules ]] || npm ci
exec npm run coverage
+3 -2
View File
@@ -1,7 +1,8 @@
#!/usr/bin/env bash
# Run the UI's (ClojureScript) tests under Node. Needs Node and a JDK, like script/ui-build.
# Run the UI's (ClojureScript) tests under Node, in a jsdom window. Needs Node and a JDK, like
# script/ui-build. script/docker-ui-test does the same with only Docker.
set -euo pipefail
cd "$(dirname "$0")/../ui"
[[ -d node_modules ]] || npm ci
exec npx shadow-cljs compile test
exec npm test
+107
View File
@@ -0,0 +1,107 @@
(ns tbd.agent.prompt
"What an LLM is told about driving this app through the page's tools (tbd.ui.webmcp), for an
MCP client outside the page (Claude, Codex) connected through WebMCP: it gets this as the
prompts and resources the page registers (tbd.ui.webmcp, in the browser: `guide`, `task`,
`tic-tac-toe`). This is a .cljc (compiled into the browser bundle, see ui/shadow-cljs.edn's
`:source-paths`) because those are genuinely needed client-side.
The page's own chatbot's system prompt is a separate, server-only concern: it lives in
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`, `work-it-out`
and `examples` from here rather than duplicating them, so the wording stays shared without the
chatbot's own instructions being bundled into the browser.
It is about acting. A model that is only asked to be helpful answers a request for action with
an offer of help, so the text says: call the tool in the same turn, chain the calls, say little
afterwards, and the few cases where not to. It is short and concrete on purpose, with examples:
the models behind LM Studio follow that better than a long list of rules.")
(def act
"Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt."
(str "Act, don't offer. When the user asks for something a tool can do, call the tool in this same\n"
"turn. Never say you are about to do something, never ask \"would you like me to\", never ask them\n"
"to confirm what they just asked for.\n"
"\n"))
(defn work-it-out
"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).
Shared with tbd.agent.instructions/chat."
[chain]
(str "Work it out yourself:\n"
"- Detail missing: take the obvious default and go. Ask only when a required argument is genuinely\n"
" 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, so an earlier one may no longer hold. Before you answer from the page or\n"
" act on it (a board, a list, an id), get what it holds now — current state if you have it, else\n"
" read it again with a tool. When the user says it changed or that you are wrong, check again\n"
" first: never go by an earlier result or by what you said before.\n"
"- A call fails: the result still comes back to you, with what went wrong. Read it, fix the\n"
" arguments or read the state, and try once more. No apologies, no explanation of what went\n"
" wrong unless it still fails.\n"
"\n"))
(defn examples
"Shared with tbd.agent.instructions/chat. `reads?` is whether looking something up (a todo's id,
the board) takes its own call first (an outside agent's list_todos/get_tic_tac_toe) or is
already in view (the chatbot's state, tbd.chat.schema/RunAgentInput's `state`) — the one place
the two agents' examples differ."
[reads?]
(str "Examples:\n"
"\"add a todo to buy milk\" -> create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\"\n"
"\"tick off the milk one\" -> " (when reads? "list_todos -> ")
"set_todo_done{\"todos\":[{\"id\":\"3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b\",\"done\":true}]} -> \"Ticked off.\"\n"
"\"untick all my todos\" -> " (when reads? "list_todos -> ") "ONE set_todo_done with every todo in \"todos\" -> "
"\"Unticked them all.\"\n"
"\"add milk and eggs\" -> ONE create_todo with both titles in \"todos\" -> \"Added both.\"\n"
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\""))
;; --- 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, so you rarely need to\n"
"navigate yourself. It only moves you there: it does not read what a page holds, so use it when\n"
"the user wants to look at a page, not to check or refresh one.\n"
"\n"
act
(work-it-out (str "- Chain calls without stopping. You need an id: list first, then act. Never invent an id, a\n"
" 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"
(examples true)))
(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.")))
(def tic-tac-toe
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent. Names
only the tools: get_tic_tac_toe, move_tic_tac_toe and their descriptions carry the rest — whose
turn it is, which side is whose, what a move is refused for — so the agent drives from those and
the game's state, and works out which side it plays from how the conversation started, rather
than the prompt assigning one. Starting over is the person's: their page has its own New game
button, no tool for it."
(str "You are playing tic-tac-toe with the person on the app's page. The tools are get_tic_tac_toe "
"and move_tic_tac_toe. Starting a new game is the person's to do, on the page: there is no "
"tool for it."))
+178
View File
@@ -0,0 +1,178 @@
(ns tbd.agent.a2a
"The A2A (Agent2Agent, https://a2a-protocol.org) server, mounted at `/a2a`, with its discovery
document at `/.well-known/agent-card.json`. Unlike /api/chat (driven by the browser's own tools),
an A2A caller has no page open, so this agent's tools are the app's server-side ones — the same
operations tbd.mcp.tools exposes to MCP, defined again here directly over
tbd.todo.service/tbd.math.core so this ns has no plumcp dependency.
A2A calls are synchronous (`message/send` only; the AgentCard's `capabilities.streaming` is
false). With no browser to run a tool and report back, this ns runs the tool loop itself: ask
the agent, run any tools it asks for, ask again, until it answers in text or `max-turns` is hit.
Protected the same way /mcp is (tbd.oauth.middleware/wrap-bearer-auth): a client authorized for
MCP can use A2A with the same token, since verifying one doesn't check which `resource` it was
minted for."
(:require [clojure.string :as str]
[malli.json-schema :as json-schema]
[muuntaja.core :as m]
[tbd.agent.core :as agent]
[tbd.agent.instructions :as instructions]
[tbd.math.core :as math]
[tbd.math.schema :as math-schema]
[tbd.mcp.schema :refer [coerce!]]
[tbd.oauth.middleware :as oauth-mw]
[tbd.todo.schema :as todo-schema]
[tbd.todo.service :as todo]))
(def ^:private max-turns
"How many rounds of tool calls the agent may make before answering, for one A2A message."
8)
;; --- Tools: the same operations tbd.mcp.tools offers MCP clients, for a caller with no page ---
(defn- ok! [{:keys [ok error]}]
(if error (throw (ex-info error {})) ok))
(defn- ->json [data] (slurp (m/encode "application/json" data)))
(defn- tool [name description schema handler]
{:name name :description description
:inputSchema (json-schema/transform schema)
:handler (fn [args {:keys [user ds]}] (str (handler (coerce! schema args) user ds)))})
(def tools
[(tool "add" "Add two numbers" math-schema/Add
(fn [{:keys [x y]} _ _] (math/add x y)))
(tool "whoami" "Says which user this call acts as, and whether they are an admin" [:map]
(fn [_ {:keys [login id admin?]} _]
(format "%s (Gitea user %d)%s" login id (if admin? ", admin" ""))))
(tool "list_todos" "Lists your todos (JSON: id, title, done, created-at, updated-at), oldest first" [:map]
(fn [_ user ds] (->json (ok! (todo/list-todos ds user)))))
(tool "get_todo" "Gets one of your todos by id (JSON)" todo-schema/IdParam
(fn [{:keys [id]} user ds] (->json (ok! (todo/find-todo ds user id)))))
(tool "create_todo" "Creates a todo for you and returns it (JSON)" todo-schema/NewTodo
(fn [{:keys [title]} user ds] (->json (ok! (todo/create! ds user title)))))
(tool "update_todo" "Changes the title and/or done flag of one of your todos and returns it (JSON)"
todo-schema/UpdateTodo
(fn [{:keys [id] :as input} user ds] (->json (ok! (todo/update! ds user id (dissoc input :id))))))
(tool "delete_todo" "Deletes one of your todos" todo-schema/IdParam
(fn [{:keys [id]} user ds] (ok! (todo/delete! ds user id)) "deleted"))])
(defn- execute-tool [ctx {:keys [name arguments]}]
(if-let [{:keys [handler]} (first (filter #(= name (:name %)) tools))]
(try (handler (m/decode "application/json" (or arguments "{}")) ctx)
(catch Exception e (str "error: " (ex-message e))))
(str "error: no such tool " (pr-str name))))
;; --- Driving the agent, running its own tool loop (no browser here) ---
(defn- collect
"Drains `pump` (see tbd.agent.core/start), returning {:text s} or {:tool-calls [...]} or
{:error s}: exactly one of them, whichever the turn ended with."
[pump]
(let [text (StringBuilder.) result (atom nil)]
(pump (fn [{:keys [content tool-calls done error]}]
(cond
content (.append text ^String content)
tool-calls (reset! result {:tool-calls tool-calls})
error (reset! result {:error error})
done (when-not @result (reset! result {:text (.toString text)})))))
@result))
(defn- run-tools!
"Answers `messages` (tbd.agent.core's internal Message shape), running any tool calls the agent
makes itself, `ctx` ({:user :ds}) being what the tools need. {:text s} or {:error s :kind ...}."
[config ctx messages]
(loop [messages messages turn 0]
(if (>= turn max-turns)
{:error "the agent didn't reach an answer in time" :kind :upstream}
(let [{:keys [ok error kind]} (agent/start config (instructions/a2a) messages tools)]
(if error
{:error error :kind kind}
(let [{:keys [text tool-calls error]} (collect ok)]
(cond
error {:error error :kind :upstream}
(seq tool-calls)
(recur (into (conj (vec messages) {:role "assistant" :content "" :tool-calls tool-calls})
(map (fn [{:keys [id name arguments]}]
{:role "tool" :tool-call-id id
:content (execute-tool ctx {:name name :arguments arguments})}))
tool-calls)
(inc turn))
:else {:text text})))))))
(defn- message-text
"The plain text of an A2A Message's `parts` ([{kind: \"text\" text: \"...\"}, ...]), joined."
[parts]
(->> parts (filter #(= "text" (or (:kind %) (get % "kind")))) (map #(or (:text %) (get % "text"))) (str/join "\n")))
(defn- agent-message
"A reply as an A2A Message: role \"agent\", one TextPart."
[text]
{:role "agent" :parts [{:kind "text" :text text}] :messageId (str (random-uuid)) :kind "message"})
;; --- JSON-RPC over HTTP ---
(defn- json [status body]
{:status status
:headers {"Content-Type" "application/json" "Cache-Control" "no-store"}
:body (m/encode "application/json" body)})
(defn- rpc-result [id result] {:jsonrpc "2.0" :id id :result result})
(defn- rpc-error [id code message] {:jsonrpc "2.0" :id id :error {:code code :message message}})
(def ^:private error-status {:unavailable 503 :upstream 502})
(defn- handle-message-send [config ctx {:keys [message]}]
(let [text (message-text (:parts message))]
(if (str/blank? text)
{:jsonrpc-error [-32602 "message has no text parts"]}
(let [{:keys [text error kind]} (run-tools! config ctx [{:role "user" :content text}])]
(if error
{:error [(get error-status kind 502) error]}
{:result (agent-message text)})))))
(defn- handler [config ds]
(fn [{:keys [user body]}]
(let [{:keys [jsonrpc id method params]} (m/decode "application/json" (slurp body))]
(cond
(not= "2.0" jsonrpc)
(json 200 (rpc-error id -32600 "invalid JSON-RPC request"))
(= "message/send" method)
(let [{:keys [result jsonrpc-error error]} (handle-message-send config {:user user :ds ds} params)]
(cond
result (json 200 (rpc-result id result))
jsonrpc-error (json 200 (apply rpc-error id jsonrpc-error))
:else (let [[status text] error] (json status (rpc-error id -32000 text)))))
:else (json 200 (rpc-error id -32601 (str "method not found: " method)))))))
(defn- agent-card [base-url]
{:name "tbd"
:description "tbd's agent: todo management and simple math, on behalf of the user who authorized this connection."
:url (str base-url "/a2a")
:version "1.0.0"
:protocolVersion "0.3.0"
:preferredTransport "JSONRPC"
:capabilities {:streaming false :pushNotifications false}
:defaultInputModes ["text/plain"]
:defaultOutputModes ["text/plain"]
:securitySchemes {"bearer" {:type "http" :scheme "bearer"
:description "An OAuth access token from this server's own authorization server (see /.well-known/oauth-protected-resource/mcp; the same token works here)."}}
:security [{"bearer" []}]
:skills (mapv (fn [{:keys [name description]}]
{:id name :name name :description description :tags ["tbd"]})
tools)})
(defn routes
"`auth` is the auth config (for `:base-url` and the OAuth check), `ds` a delay of the app's
database, `chat` the agent config (see tbd.agent.core/env-config)."
[auth ds chat]
["" {:no-doc true}
["/.well-known/agent-card.json"
{:middleware ^:replace []
:get {:handler (fn [_req] (json 200 (agent-card (:base-url auth))))}}]
["/a2a"
{:middleware ^:replace []
:post {:handler (-> (handler chat ds) (oauth-mw/wrap-bearer-auth auth ds))}}]])
+340
View File
@@ -0,0 +1,340 @@
(ns tbd.agent.core
"The chatbot's agent: a LangChain4j `StreamingChatModel` talking to the OpenAI-compatible LM
Studio server named by the environment. No Ring here; tbd.chat.routes owns that, tbd.agent.a2a
drives the same model for the A2A server.
`start` sends the request and gives {:ok pump} or {:error text :kind :unavailable|:upstream}.
`pump` forwards the reply, as it's generated, to a function of events: {:thinking \"text\"},
{:content \"text\"}, {:tool-calls [{:id :name :arguments}]} (arguments is the JSON text the
model wrote), and finally {:done true} or {:error \"text\"}. This event shape is internal —
tbd.chat.routes and tbd.agent.a2a each translate it to their own wire protocol — and is what
tbd.chat.trace watches.
`start` takes `system-text` already composed by the caller (tbd.agent.instructions) and sends it
as the first message. `tools` are MCP-style {:name :description :inputSchema}, converted to
LangChain4j's typed tool specifications (tbd.agent.json-schema); running them and reporting the
result back is the caller's job.
Every turn is traced (tbd.chat.trace: what was asked, how the reply went, whether the model
looks stuck in a loop). A turn that loops isn't left running or simply failed: `pump` cancels it
and retries once, nudged to answer, erroring only if the retry loops too."
(:require [clojure.string :as str]
[tbd.agent.json-schema :as json-schema]
[tbd.chat.trace :as trace])
(:import (dev.langchain4j.agent.tool ToolExecutionRequest ToolSpecification)
(dev.langchain4j.data.message AiMessage ChatMessage SystemMessage ToolExecutionResultMessage UserMessage)
(dev.langchain4j.http.client.jdk JdkHttpClientBuilder)
(dev.langchain4j.model.chat StreamingChatModel)
(dev.langchain4j.model.chat.request ChatRequest)
(dev.langchain4j.model.chat.response
ChatResponse CompleteToolCall PartialResponse PartialResponseContext
PartialThinking PartialThinkingContext PartialToolCallContext
StreamingChatResponseHandler StreamingHandle)
(dev.langchain4j.model.openai OpenAiStreamingChatModel)
(java.net.http HttpClient HttpClient$Version)
(java.time Duration)
(java.util.concurrent LinkedBlockingQueue ScheduledFuture ScheduledThreadPoolExecutor ThreadFactory TimeUnit)))
(def default-timeout-seconds 120)
(defn- env-val [env k]
(let [v (get env k)]
(when-not (str/blank? v) (str/trim v))))
;; HTTP/1.1 on purpose: the JDK client's default asks a plain-http server to upgrade to HTTP/2
;; (`Upgrade: h2c`), and LM Studio never answers that, so requests would hang for the full timeout.
(defn- jdk-http-client-builder []
(-> (JdkHttpClientBuilder.)
(.httpClientBuilder (-> (HttpClient/newBuilder) (.version HttpClient$Version/HTTP_1_1)))))
(defn- api-base-url
"`url` (see env-config) with `/v1` appended if missing: LangChain4j posts straight to
`<baseUrl>/chat/completions` without adding it, and LM Studio without it answers 200 with a JSON
error body that reads as an empty reply."
[url]
(if (str/ends-with? url "/v1") url (str url "/v1")))
(defn- build-chat-model ^StreamingChatModel [{:keys [url model api-key timeout-seconds]}]
(let [builder (-> (OpenAiStreamingChatModel/builder)
(.httpClientBuilder (jdk-http-client-builder))
(.baseUrl (api-base-url url))
(.apiKey (or api-key "not-needed"))
(.timeout (Duration/ofSeconds timeout-seconds))
;; LM Studio's reasoning models send `reasoning_content`; this is what maps it
;; onto onPartialThinking instead of dropping it.
(.returnThinking true))]
(when model (.modelName builder model))
(.build builder)))
(defn env-config
"Chat config from environment variables:
LMSTUDIO_URL where the LM Studio server is, e.g. http://192.168.1.20:1234 (chat is off without it)
LMSTUDIO_MODEL the model id to ask for (optional: LM Studio uses the model that is loaded)
LMSTUDIO_API_KEY sent as a bearer token, when the server wants one (optional)
LMSTUDIO_TIMEOUT_SECONDS how long the server may stay silent before giving up (default 120)
CHAT_TRACE_FILE a file to append a JSON trace of every turn to, with the model's full reasoning and
replies and the messages it was sent (optional: without it, each turn is only
summarised in the log)"
([] (env-config (System/getenv)))
([env]
(let [config {:url (some-> (env-val env "LMSTUDIO_URL") (str/replace #"/+$" ""))
:model (env-val env "LMSTUDIO_MODEL")
:api-key (env-val env "LMSTUDIO_API_KEY")
:timeout-seconds (or (some-> (env-val env "LMSTUDIO_TIMEOUT_SECONDS") parse-long)
default-timeout-seconds)
:trace (trace/config-for (env-val env "CHAT_TRACE_FILE"))}]
(assoc config :chat-model-delay (delay (build-chat-model config))))))
(defn configured? [{:keys [url]}] (some? url))
(defn- chat-model
"The config's `StreamingChatModel`: `:chat-model` directly, when a caller (a test) gives one, else
the one built from `:url`/`:model`/`:api-key`/`:timeout-seconds`, built once and reused."
^StreamingChatModel [config]
(or (:chat-model config) (force (:chat-model-delay config))))
;; --- Building the request ---
(defn- llm-message
"One message of the conversation (see tbd.chat.schema/Message) as a LangChain4j ChatMessage."
^ChatMessage [{:keys [role content tool-calls tool-call-id]}]
(case role
"user" (UserMessage/from ^String content)
"assistant" (if (seq tool-calls)
(AiMessage/from (str content)
^java.util.List
(mapv (fn [{:keys [id name arguments]}]
(-> (ToolExecutionRequest/builder)
(.id id) (.name name) (.arguments arguments)
.build))
tool-calls))
(AiMessage/from ^String content))
"tool" (ToolExecutionResultMessage/toolExecutionResultMessage
^String tool-call-id "" ^String content)))
(defn- llm-tool
"An MCP tool's metadata as a function the LLM may call."
^ToolSpecification [{:keys [name description inputSchema]}]
(let [builder (-> (ToolSpecification/builder)
(.name name)
(.parameters (json-schema/tool-parameters inputSchema)))]
(when description (.description builder description))
(.build builder)))
(defn- chat-request ^ChatRequest [system-text messages tools]
(let [builder (-> (ChatRequest/builder)
(.messages ^java.util.List (into [(SystemMessage/from ^String system-text)]
(map llm-message) messages)))]
(when (seq tools)
(.toolSpecifications builder ^java.util.List (mapv llm-tool tools)))
(.build builder)))
;; --- Reading the reply ---
(def ^:private watchdog
(delay (doto (ScheduledThreadPoolExecutor.
1 (reify ThreadFactory
(newThread [_ r] (doto (Thread. ^Runnable r "chat-watchdog") (.setDaemon true)))))
(.setRemoveOnCancelPolicy true))))
(defn- exception-detail [^Throwable e]
(str (class e) ": " (.getMessage e)))
(defn- fail
([text] (fail text nil))
([text detail]
(println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")")))
text))
(defn- loop-abort-text
"What the user is told when a retried turn (see `pump`) still loops."
[{:keys [kind]}]
(case kind
:repeated-thinking "the model got stuck repeating itself, and the reply was stopped"
:long-reasoning "the model's reasoning went on without end, and the reply was stopped"))
(def ^:private loop-nudge
"Appended to the system prompt for pump's one retry of a looping turn."
"\n\nYou have been reasoning for a long time without answering. Stop reasoning now: give your final answer immediately, or call the tool you need.")
(defn- streaming-handler
"A StreamingChatResponseHandler that pushes every callback onto `queue` as a map: {:content s},
{:thinking s}, {:tool-call {:id :name :arguments}} (once a call is fully assembled), {:complete
response} or {:error throwable}. `handle!` is called with the first StreamingHandle seen, so the
caller can cancel a stuck stream."
^StreamingChatResponseHandler [^LinkedBlockingQueue queue handle!]
(let [capture! (fn [^StreamingHandle h] (when h (handle! h)))]
;; No type hints on the reify methods' params below: hinting an overloaded interface method's
;; params (onPartialResponse/onPartialThinking/onPartialToolCall each have a 1- and a 2-arg
;; overload) confuses Clojure's overload resolution (`NewInstanceMethod.parse`), which throws
;; "Mismatched return type" instead of picking the right one. Arity alone disambiguates fine.
(reify StreamingChatResponseHandler
(onPartialResponse [_ partial ctx]
(capture! (.streamingHandle ^PartialResponseContext ctx))
(.put queue {:content (.text ^PartialResponse partial)})
nil)
(onPartialThinking [_ partial ctx]
(capture! (.streamingHandle ^PartialThinkingContext ctx))
(.put queue {:thinking (.text ^PartialThinking partial)})
nil)
(onPartialToolCall [_ _partial ctx]
(capture! (.streamingHandle ^PartialToolCallContext ctx))
nil)
(onCompleteToolCall [_ complete]
(let [req (.toolExecutionRequest ^CompleteToolCall complete)]
(.put queue {:tool-call {:id (.id req) :name (.name req) :arguments (.arguments req)}}))
nil)
(onCompleteResponse [_ response]
(.put queue {:complete response})
nil)
(onError [_ error]
(.put queue {:error error})
nil))))
(defn- usage-of [^ChatResponse response]
(when-let [usage (.tokenUsage response)]
{:prompt_tokens (.inputTokenCount usage)
:completion_tokens (.outputTokenCount usage)
:total_tokens (.totalTokenCount usage)}))
(defn- finish-reason-of [^ChatResponse response]
(some-> (.finishReason response) str str/lower-case))
(defn- send-request!
"Sends `system-text`/`messages`/`tools`, and waits (up to `timeout-seconds`) for the first sign
of life: {:ok {:queue :handle-atom :first-item}}, or {:error text :detail text} for an LLM that
is down, refuses, or stays silent too long. Used for the turn's first attempt (`start`) and for
the retry `pump` sends after a turn that loops."
[config system-text messages tools timeout-seconds]
(try
(let [queue (LinkedBlockingQueue.)
handle-atom (atom nil)
handler (streaming-handler queue #(reset! handle-atom %))]
(.chat (chat-model config) (chat-request system-text messages tools) handler)
(if-let [first-item (.poll queue (long timeout-seconds) TimeUnit/SECONDS)]
(if (:error first-item)
{:error "the LLM server can't be reached or refused" :detail (exception-detail (:error first-item))}
{:ok {:queue queue :handle-atom handle-atom :first-item first-item}})
{:error "the LLM server took too long to answer" :detail (str timeout-seconds "s of silence")}))
(catch Exception e
{:error "the LLM server can't be reached" :detail (exception-detail e)})))
(defn- pump
"Drains `queue`, starting from the already-polled `first-item` (see send-request!), calling
`emit` with each event (see the ns docstring). `timeout-seconds` of silence between items is an
error, closing the stream via `handle-atom`.
A looping model is never silent, so that timeout can't catch it; `tracer` (tbd.chat.trace/observe!)
watches for that instead. The first time a turn loops, the stream is cancelled and resent with
`loop-nudge` appended to `system-text`, as a fresh attempt (the caller only sees a pause); looping
again on the retry, or failing to start it, is an error. An exception from `emit` ends the attempt
too, closing the stream, and is rethrown."
[config system-text messages tools timeout-seconds emit tracer
^LinkedBlockingQueue queue handle-atom first-item retried?]
(let [timer (atom nil)
timed-out? (atom false)
cancel-stream! (fn []
(when-let [^StreamingHandle h @handle-atom]
(try (.cancel h) (catch Exception _ nil))))
arm! (fn []
(some-> ^ScheduledFuture @timer (.cancel false))
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
^Runnable (fn [] (reset! timed-out? true) (cancel-stream!))
(long timeout-seconds) TimeUnit/SECONDS)))
retry! (fn []
(cancel-stream!)
(some-> ^ScheduledFuture @timer (.cancel false))
(let [nudged-text (str system-text loop-nudge)
tracer' (trace/begin! (:trace config) {:messages messages :tools tools :model (:model config)
:system-text nudged-text})
{:keys [ok error detail]} (send-request! config nudged-text messages tools timeout-seconds)]
(if error
(let [text (fail error detail)]
(trace/finish! tracer' {:outcome :upstream-error :error text :detail detail})
(emit {:error text}))
(pump config nudged-text messages tools timeout-seconds emit tracer'
(:queue ok) (:handle-atom ok) (:first-item ok) true))))]
(arm!)
(try
(loop [item first-item
replied? false
calls []]
(cond
(:error item)
(let [^Throwable e (:error item)
text (if @timed-out?
(fail "the LLM server took too long to answer" (str timeout-seconds "s of silence"))
(fail "the LLM server can't be reached or refused" (exception-detail e)))]
(trace/finish! tracer {:outcome :error :error text :detail (exception-detail e)})
(emit {:error text}))
(:complete item)
(let [^ChatResponse response (:complete item)
ai (.aiMessage response)
calls (if (seq calls) calls
(mapv (fn [^ToolExecutionRequest r]
{:id (.id r) :name (.name r) :arguments (.arguments r)})
(.toolExecutionRequests ai)))
;; A provider that never streamed tokens (batched the whole reply) has its text
;; only here, never through :content items above.
batched-text (when (and (not replied?) (empty? calls) (not (str/blank? (.text ai))))
(.text ai))
event {:finish-reason (finish-reason-of response) :usage (usage-of response)}]
(trace/observe! tracer event)
(cond
(seq calls) (do (trace/finish! tracer {:outcome :tool-calls :calls calls})
(emit {:tool-calls calls})
(emit {:done true}))
batched-text (do (trace/finish! tracer {:outcome :done})
(emit {:content batched-text})
(emit {:done true}))
(or replied? (not (str/blank? (.text ai))))
(do (trace/finish! tracer {:outcome :done}) (emit {:done true}))
:else (let [text (fail "the LLM server sent no reply")]
(trace/finish! tracer {:outcome :error :error text})
(emit {:error text}))))
:else
(let [abort (trace/observe! tracer (select-keys item [:content :thinking]))]
(when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out))
(cond
(and abort (not retried?))
(do (trace/finish! tracer {:outcome :looped}) (retry!))
abort
(let [text (fail (loop-abort-text abort))]
(trace/finish! tracer {:outcome :error :error text})
(cancel-stream!)
(emit {:error text}))
:else
(do (arm!)
(recur (.take queue)
(or replied? (contains? item :content))
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))))
(finally
(trace/finish! tracer {:outcome :aborted})
(some-> ^ScheduledFuture @timer (.cancel false))
(cancel-stream!)))))
(defn start
"Sends the LLM `messages` (tbd.chat.schema/Message) and the `tools` it may ask to be run (MCP's
{:name :description :inputSchema}; none if nil), after `system-text` (composed by the caller,
see tbd.agent.instructions). Waits for the first sign of life so an LLM that is down or refuses
comes back as a clean {:error text :kind :unavailable|:upstream} rather than an error mid-stream.
Otherwise {:ok pump}: `(pump emit)` blocks until the reply is complete (retrying once on its own
if the model loops, see `pump`), calling `emit` with its events. If `emit` throws, the request to
the LLM is closed and the exception is rethrown."
[{:keys [timeout-seconds trace] :as config} system-text messages tools]
(if-not (configured? config)
{:error "chat is not configured" :kind :unavailable}
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)
:system-text system-text})
{:keys [ok error detail]} (send-request! config system-text messages tools timeout-seconds)]
(if error
(do (fail error detail)
(trace/finish! tracer {:outcome :upstream-error :error error :detail detail})
{:error error :kind :upstream})
{:ok (fn [emit]
(pump config system-text messages tools timeout-seconds emit tracer
(:queue ok) (:handle-atom ok) (:first-item ok) false))}))))
+68
View File
@@ -0,0 +1,68 @@
(ns tbd.agent.instructions
"The system prompts of the two agents tbd.agent.core drives: `chat`, for the in-page chatbot
behind /api/chat, and `a2a`, for the A2A server (tbd.agent.a2a) other agents call. Server-only
on purpose: unlike tbd.agent.prompt (a .cljc the browser bundle also needs, for WebMCP's
`guide`/`task`/`tic-tac-toe`), this ns is never on ui/shadow-cljs.edn's `:source-paths`, so the
chatbot's own instructions can never end up in the compiled UI. It reuses the wording that is
genuinely shared (`act`, `work-it-out`, `examples`) from tbd.agent.prompt rather than
duplicating it."
(:require [clojure.string :as str]
[jsonista.core :as json]
[tbd.agent.prompt :as prompt]))
(defn chat
"The in-page chatbot's system prompt, the start of its system message: tbd.agent.core adds
where the user is and the tools it has. Its calls show under its message, so it answers in a
sentence and never repeats them."
[]
(str "You are the assistant built into this web app. Your tools type, click and read on the page the\n"
"user is looking at, and every call shows on their screen the moment you make it.\n"
"\n"
prompt/act
(prompt/work-it-out (str "- Chain calls without stopping. The tool you need belongs to another page: navigate there, then\n"
" use it. Never invent an id, a title or the state of the page: it's in \"Current state of the\n"
" page\" below, if there is one, or read it with a tool.\n"))
"Then say one short plain sentence: \"Added it.\" \"That's 23.\" The call and its result are already\n"
"on screen under your message, so never repeat them, never paste JSON, never use markdown,\n"
"headings or bullet lists. Say something was done only if a tool result says it was.\n"
"\n"
"Some things are not tool work: greetings, questions about you, questions you can simply answer.\n"
"Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n"
"the tools you have. Think briefly before you act.\n"
"\n"
(prompt/examples false)))
(defn chat-system-message
"`chat`'s prompt, with, last, where the user is (`page`), the names of the `tools` on offer
there, and `state` (see tbd.chat.schema/RunAgentInput) — what the page is showing right now, so
the model is never told to call a tool to read what it already has. The tools' names are in the
request's `tools` too, but a model picks them more readily when the instructions say them as
well, and it can say what it can do without a call. One message, and the first: several chat
templates (Gemma's, Mistral's) refuse more than one system message, or one that isn't first."
[page tools state]
(cond-> (chat)
page (str "\n\nThe user is on the \"" page "\" page of the app: what it shows is what they can see.")
(seq tools) (str (if page " Its" "\n\nYour")
" tools: " (str/join ", " (map :name tools))
". The tools of other pages are offered once you navigate there.")
(seq state) (str "\n\nCurrent state of the page (JSON), current as of this message. Go by it, not an\n"
"earlier tool result or what you said before: never call a tool just to read it,\n"
"only to act:\n" (json/write-value-as-string state))))
(defn a2a
"The A2A server's system prompt: an outside agent calling this app directly, not through a
page, so it has no DOM to act on and no visual feedback to lean on. Its tools are the app's
server-side ones (tbd.mcp.tools, the same the MCP server offers), not a page's."
[]
(str "You are tbd's agent, reachable over the Agent2Agent protocol. You act on behalf of the user\n"
"who authorized the caller, using the tools you were given: todo management and anything else\n"
"this server exposes as a tool. You have no page open and no visual feedback beyond what a tool\n"
"returns.\n"
"\n"
prompt/act
(prompt/work-it-out (str "- You need an id: list first, then act. Never invent an id, a title or the state of the data:\n"
" read it with a tool.\n"))
"Then report in one short plain sentence, from the tool results: \"Added it.\" \"That's 23.\" Don't\n"
"paste JSON, don't describe the tool call itself, just its outcome.\n"
"\n"
(prompt/examples true)))
+80
View File
@@ -0,0 +1,80 @@
(ns tbd.agent.json-schema
"Translates a tool's `inputSchema` (plain JSON Schema, decoded to a Clojure map — see
tbd.chat.schema/Tool) into LangChain4j's typed `JsonSchemaElement` tree, which is what
`ToolSpecification.Builder/parameters` needs (dev.langchain4j.model.chat.request.json). The
browser is the one authoring these schemas (tbd.ui.webmcp), so this only has to cover the shapes
MCP-style tool schemas actually use: object/string/number/integer/boolean/array/enum, nested
arbitrarily. Anything else (a bare `:enum` without a `:type`, an unrecognized `:type`) falls back
to a permissive `JsonRawSchema` dump of the schema as JSON, rather than failing the request."
(:require [clojure.string :as str]
[muuntaja.core :as m])
(:import (dev.langchain4j.model.chat.request.json
JsonArraySchema JsonBooleanSchema JsonEnumSchema JsonIntegerSchema
JsonNumberSchema JsonObjectSchema JsonRawSchema JsonSchemaElement JsonStringSchema)))
(defn- field
"`m`'s value at `k`, trying the keyword first (how muuntaja decodes JSON) then the string, so
this works whether or not something upstream keywordized the nested schema too."
[m k]
(or (get m (keyword k)) (get m (name k))))
(defn- raw
"A schema element that isn't one of the shapes below: dumped as JSON and wrapped in
`JsonRawSchema` rather than dropped, so the LLM still sees it."
[schema]
(JsonRawSchema/from (slurp (m/encode "application/json" schema))))
(declare of)
(defn- object-schema ^JsonObjectSchema [schema]
(let [builder (JsonObjectSchema/builder)]
(doseq [[k v] (field schema :properties)]
(.addProperty builder (name k) (of v)))
(when-let [required (seq (field schema :required))]
(.required builder ^java.util.List (mapv name required)))
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defn- array-schema ^JsonArraySchema [schema]
(let [builder (JsonArraySchema/builder)]
(when-let [items (field schema :items)]
(.items builder (of items)))
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defn- enum-schema ^JsonEnumSchema [schema enum-values]
(let [builder (.enumValues (JsonEnumSchema/builder) ^java.util.List (mapv str enum-values))]
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defmacro ^:private simple-schema [ctor schema]
`(let [builder# (~ctor)]
(when-let [d# (field ~schema :description)]
(.description builder# d#))
(.build builder#)))
(defn of
"`schema` (a JSON Schema map, keys keyword or string) as a `JsonSchemaElement`."
^JsonSchemaElement [schema]
(if-not (map? schema)
(raw schema)
(let [type (some-> (field schema :type) name str/lower-case)
enum-values (field schema :enum)]
(cond
(and (seq enum-values) (or (nil? type) (= "string" type))) (enum-schema schema enum-values)
(= "object" type) (object-schema schema)
(= "array" type) (array-schema schema)
(= "string" type) (simple-schema #(JsonStringSchema/builder) schema)
(= "integer" type) (simple-schema #(JsonIntegerSchema/builder) schema)
(= "number" type) (simple-schema #(JsonNumberSchema/builder) schema)
(= "boolean" type) (simple-schema #(JsonBooleanSchema/builder) schema)
:else (raw schema)))))
(defn tool-parameters
"A tool's MCP-style `inputSchema` (already validated as an object schema, see tbd.chat.schema/Tool)
as the `JsonObjectSchema` a `ToolSpecification` needs."
^JsonObjectSchema [input-schema]
(object-schema input-schema))
+51
View File
@@ -0,0 +1,51 @@
(ns tbd.chat.db
"SQLite persistence for the chat widget's history, in the app's database (see tbd.sqlite). Not
the AG-UI run itself (tbd.chat.routes' /api/chat stays stateless) — this is the browser's own
conversation (tbd.ui.db's :chat :messages), saved so a reload or a new browser can pick it back
up. One row per user: the whole conversation is kept as one EDN blob and replaced wholesale on
each save, the same way the browser already treats it as a single vector, never a diff."
(:require [clojure.edn :as edn]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def ^:private create-chat-history
;; `owner_id` is the user's id in Gitea, like tbd.todo.db's todos.
"CREATE TABLE IF NOT EXISTS chat_history (
owner_id INTEGER PRIMARY KEY,
messages TEXT NOT NULL,
updated_at INTEGER NOT NULL)")
(defn migrate!
"Creates the chat_history table in the database `ds`, or brings it up to date."
[ds]
(jdbc/execute! ds [create-chat-history]))
(defn open
"A database with just the chat_history table, at `path`; the app opens one with every group's
tables (see tbd.core), which this is for tests of the group on its own."
[path]
(sqlite/open path migrate!))
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
(defn get-history
"The owner's stored conversation (tbd.chat.schema/HistoryMessage maps), oldest first, or [] if
nothing is stored for them yet."
[ds owner-id]
(if-let [{:keys [messages]} (jdbc/execute-one!
ds ["SELECT messages FROM chat_history WHERE owner_id = ?" owner-id] opts)]
(edn/read-string messages)
[]))
(defn save-history!
"Replaces the owner's stored conversation with `messages`."
[ds owner-id messages now]
(jdbc/execute! ds ["INSERT INTO chat_history (owner_id, messages, updated_at) VALUES (?, ?, ?)
ON CONFLICT (owner_id) DO UPDATE SET messages = excluded.messages, updated_at = excluded.updated_at"
owner-id (pr-str messages) now]))
(defn clear-history!
"Deletes the owner's stored conversation, if any."
[ds owner-id]
(jdbc/execute! ds ["DELETE FROM chat_history WHERE owner_id = ?" owner-id]))
+161
View File
@@ -0,0 +1,161 @@
(ns tbd.chat.routes
"/api/chat: an AG-UI (https://docs.ag-ui.com) run. A caller POSTs a RunAgentInput
(tbd.chat.schema/RunAgentInput) and gets the agent's reply streamed back as AG-UI server-sent
events: RUN_STARTED, then TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates,
then RUN_FINISHED or RUN_ERROR. The agent itself is tbd.agent.core; this ns only translates its
internal event shape ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}) to AG-UI's wire
format. AG-UI's frontend-tool model (the agent asks for a call, the browser runs it and sends
the result back as a `tool` message on the next run) is exactly the loop tbd.ui.events drives."
(:require [muuntaja.core :as m]
[ring.core.protocols :as ring-protocols]
[tbd.agent.core :as agent]
[tbd.chat.db :as chat-db]
[tbd.chat.schema :as schema]
[tbd.http :refer [respond]])
(:import (java.io IOException OutputStream)
(java.nio.charset StandardCharsets)))
(def ^:private error-status {:unavailable 503 :upstream 502})
(defn- sse-event
"One server-sent event: `event` (an AG-UI BaseEvent, a plain map with a `:type`) as JSON, on a
single line."
^bytes [event]
(.getBytes (str "data: " (slurp (m/encode "application/json" event)) "\n\n") StandardCharsets/UTF_8))
;; --- Internal pump events -> AG-UI events ---
(defn- open-reasoning [{:keys [reasoning-id] :as state}]
(if (:reasoning-open? state)
[state []]
[(assoc state :reasoning-open? true)
[{:type "REASONING_START" :messageId reasoning-id}
{:type "REASONING_MESSAGE_START" :messageId reasoning-id :role "reasoning"}]]))
(defn- close-reasoning [{:keys [reasoning-id] :as state}]
(if-not (:reasoning-open? state)
[state []]
[(assoc state :reasoning-open? false)
[{:type "REASONING_MESSAGE_END" :messageId reasoning-id}
{:type "REASONING_END" :messageId reasoning-id}]]))
(defn- open-text [{:keys [text-id] :as state}]
(if (:text-open? state)
[state []]
[(assoc state :text-open? true)
[{:type "TEXT_MESSAGE_START" :messageId text-id :role "assistant"}]]))
(defn- close-text [{:keys [text-id] :as state}]
(if-not (:text-open? state)
[state []]
[(assoc state :text-open? false)
[{:type "TEXT_MESSAGE_END" :messageId text-id}]]))
(defn- close-all [state]
(let [[state text-events] (close-text state)
[state reasoning-events] (close-reasoning state)]
[state (into text-events reasoning-events)]))
(defn- tool-call-events [{:keys [id name arguments]}]
[{:type "TOOL_CALL_START" :toolCallId id :toolCallName name}
{:type "TOOL_CALL_ARGS" :toolCallId id :delta (str arguments)}
{:type "TOOL_CALL_END" :toolCallId id}])
(defn- ag-ui-events
"[state' events]: `state` ({:reasoning-id :text-id :reasoning-open? :text-open?}) and the AG-UI
events `event` (tbd.agent.core's internal shape) translates to, opening/closing the
reasoning/text message streams as the model switches between them."
[state {:keys [thinking content tool-calls done error]} thread-id run-id]
(cond
thinking (let [[state closed] (close-text state)
[state opened] (open-reasoning state)]
[state (conj (into closed opened)
{:type "REASONING_MESSAGE_CONTENT" :messageId (:reasoning-id state) :delta thinking})])
content (let [[state closed] (close-reasoning state)
[state opened] (open-text state)]
[state (conj (into closed opened)
{:type "TEXT_MESSAGE_CONTENT" :messageId (:text-id state) :delta content})])
tool-calls (let [[state closing] (close-all state)]
[state (into closing (mapcat tool-call-events) tool-calls)])
done (let [[state closing] (close-all state)]
[state (conj closing {:type "RUN_FINISHED" :threadId thread-id :runId run-id})])
error (let [[state closing] (close-all state)]
[state (conj closing {:type "RUN_ERROR" :message error})])
:else [state []]))
(defn- event-stream
"A response body that writes what `pump` (see tbd.agent.core/start) forwards, translated to AG-UI
events, flushing after every one so they arrive as they are generated. A browser that goes away
stops it, and the LLM's request with it."
[pump thread-id run-id]
(reify ring-protocols/StreamableResponseBody
(write-body-to-stream [_ _ out]
(let [state (atom {:reasoning-id (str (random-uuid)) :text-id (str (random-uuid))
:reasoning-open? false :text-open? false})
write! (fn [event] (.write ^OutputStream out (sse-event event)) (.flush ^OutputStream out))]
(try
(write! {:type "RUN_STARTED" :threadId thread-id :runId run-id})
(pump (fn [internal-event]
(let [[state' events] (ag-ui-events @state internal-event thread-id run-id)]
(reset! state state')
(run! write! events))))
(catch IOException _ nil))))))
(defn- chat-handler [config]
(fn [{{{:keys [messages tools threadId runId] :as input} :body} :parameters}]
(let [thread-id (or threadId (str (random-uuid)))
run-id (or runId (str (random-uuid)))
system-text (schema/system-text input)
internal-messages (mapv schema/->internal-message messages)
internal-tools (mapv schema/->internal-tool tools)
{:keys [ok error kind]} (agent/start config system-text internal-messages internal-tools)]
(if error
(respond (error-status kind) {:error error})
{:status 200
:headers {"Content-Type" "text/event-stream; charset=utf-8"
"Cache-Control" "no-cache"
;; nginx would otherwise hold the events back until the reply is over
"X-Accel-Buffering" "no"}
:body (event-stream ok thread-id run-id)}))))
(defn- history-handler [ds]
(fn [{:keys [user]}]
(respond 200 {:messages (chat-db/get-history @ds (:id user))})))
(defn- save-history-handler [ds]
(fn [{{{:keys [messages]} :body} :parameters :keys [user]}]
(chat-db/save-history! @ds (:id user) messages (System/currentTimeMillis))
(respond 200 {:saved true})))
(defn- clear-history-handler [ds]
(fn [{:keys [user]}]
(chat-db/clear-history! @ds (:id user))
(respond 200 {:cleared true})))
(defn routes
"`config` is the agent config (see tbd.agent.core/env-config). `ds` is a delay of the app's
database (see tbd.sqlite/open), for /api/chat/history. Only logged-in users may chat: every
message costs the LLM server's time."
[config ds]
["/api/chat"
{:tags ["chat"]}
[""
{:post {:login? true
:summary "An AG-UI (https://docs.ag-ui.com) run: POST a RunAgentInput (the conversation so far, tools on offer, and `context` — the page the user is on travels as {\"description\":\"page\",\"value\":\"...\"}); the reply streams back as AG-UI server-sent events (RUN_STARTED, TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates, then RUN_FINISHED or RUN_ERROR). Failures before the run starts are ordinary errors: 400 for an invalid input, 502 if the LLM server can't be reached or refuses, 503 if the agent isn't configured"
:parameters {:body schema/RunAgentInput}
:handler (chat-handler config)}}]
["/history"
{:login? true}
[""
{:get {:summary "The logged-in user's stored chat history (tbd.chat.schema/HistoryMessage, oldest first); {:messages []} if there is none"
:handler (history-handler ds)}
:put {:summary "Replaces the logged-in user's stored chat history with the given messages — the browser's own full conversation, saved so a reload or another browser can restore it"
:parameters {:body schema/History}
:handler (save-history-handler ds)}
:delete {:summary "Clears the logged-in user's stored chat history (the \"Clear\" button: the next reload starts a new session)"
:handler (clear-history-handler ds)}}]]])
+193
View File
@@ -0,0 +1,193 @@
(ns tbd.chat.schema
"The shape of /api/chat's request, as Malli schemas, coerced by tbd.chat.routes: an AG-UI
RunAgentInput (https://docs.ag-ui.com), the standard wire format for an agent↔frontend run. The
limits are what keeps the endpoint from being a free pipe to the LLM: a conversation is bounded
in length, and the UI (tbd.ui.events) sends no more than `max-messages` of it.
The conversation can hold the model's use of the page's tools (see tbd.ui.model-context): an
assistant message that asks for calls (`:toolCalls`), followed by one \"tool\" role message with
the result of each. Those are the browser's to say, so they are as bounded as the rest. Which
page the user is on travels as a `context` entry ({:description \"page\" :value \"todos\"}) rather
than a dedicated field — AG-UI's place for ambient, non-conversation information."
(:require [tbd.agent.instructions :as instructions]))
(def max-messages 40)
(def max-message-length 8000)
(def max-tools 32)
(def max-tool-calls 16)
(def ^:private max-tool-schema-length
"How long a tool's metadata may be, printed: room for a tool of a dozen parameters."
5000)
(defn- small? [tool]
(<= (count (pr-str tool)) max-tool-schema-length))
(def ^:private max-state-length
"How long RunAgentInput's `state` may be, printed: room for a todo list or a game board, not a
free way to put an unbounded payload in every system prompt."
8000)
(defn- small-state? [state]
(<= (count (pr-str state)) max-state-length))
(def Tool
"AG-UI's Tool: {name, description, parameters}. `parameters` is JSON Schema for the arguments,
which is the LLM's to read, so it is any (small) object."
[:and
[:map
[:name [:re #"^[a-zA-Z0-9_-]{1,64}$"]]
[:description {:optional true} [:string {:max 2000}]]
[:parameters {:optional true} [:map-of :keyword :any]]]
[:fn small?]])
(def ^:private Id [:string {:min 1 :max 200}])
(def FunctionCall
[:map
[:name [:string {:min 1 :max 200}]]
[:arguments [:string {:max 100000}]]])
(def ToolCall
"AG-UI's ToolCall: a call the model asked for. Its name and arguments are the model's own
words: nothing says they are a tool of the page, or JSON, so they are only bounded, generously
(a conversation that the server refused would be stuck: the UI sends it again with the next
message)."
[:map
[:id Id]
[:type [:= "function"]]
[:function FunctionCall]])
(def Message
"AG-UI's Message, narrowed to the roles this endpoint accepts from a caller: user, assistant
(optionally with `toolCalls`) and tool (answering one). `id` identifies the message within the
conversation (AG-UI requires it); this endpoint doesn't need it to be unique or stable, only
present."
[:multi {:dispatch :role}
["user" [:map
[:id Id]
[:role [:= "user"]]
[:content [:string {:min 1 :max max-message-length}]]]]
["assistant" [:and
[:map
[:id Id]
[:role [:= "assistant"]]
[:content {:optional true} [:string {:max max-message-length}]]
[:toolCalls {:optional true} [:vector {:max max-tool-calls} ToolCall]]]
[:fn (fn [{:keys [content toolCalls]}] (or (seq content) (seq toolCalls)))]]]
["tool" [:map
[:id Id]
[:role [:= "tool"]]
[:toolCallId Id]
[:content [:string {:min 1 :max max-message-length}]]]]])
(def Context
"AG-UI's Context: a named piece of ambient information for the run. The page the user is on is
sent as {:description \"page\" :value \"<page id>\"}."
[:map
[:description [:string {:max 200}]]
[:value [:string {:max 2000}]]])
(def RunAgentInput
"AG-UI's RunAgentInput: the conversation so far, oldest first (`messages`), the tools on offer
for this run (`tools`), ambient information (`context`, which is where `page` travels), and
`state` — what the page is showing right now (its todo list, its tic-tac-toe board, ...), so the
model has it up front instead of spending a tool call to read it (see tbd.ui.model-context's
state registry, which is what fills it on the browser's side).
`threadId`/`runId` identify the run to the client; this server is stateless between turns (the
browser resends the whole conversation each time, see tbd.ui.events), so it only echoes them
back, never reads them."
[:map
[:threadId {:optional true} [:string {:max 200}]]
[:runId {:optional true} [:string {:max 200}]]
[:messages [:vector {:min 1 :max max-messages} Message]]
[:tools {:optional true} [:vector {:max max-tools} Tool]]
[:context {:optional true} [:vector {:max 8} Context]]
[:state {:optional true} [:and [:map-of :keyword :any] [:fn small-state?]]]])
(def max-history-messages
"How many messages of a browser's own conversation (see tbd.ui.db's :chat :messages) the
/api/chat/history endpoint stores for it, the most recent (see tbd.ui.events/storable) — more
than max-messages, since this is scrollback for the user, not context for the LLM."
100)
(def max-history-content-length
"The longest tool result, or reply's reasoning, /api/chat/history stores: far over
`max-message-length` (what the LLM is sent), since the stored conversation is the whole log for
\"Expand tool use\"/\"Show reasoning\" to show after a reload, not context for the LLM."
100000)
(def max-history-length
"How long the stored conversation may be, printed, all told (see tbd.ui.events/storable, which
drops its oldest messages to stay within it)."
1000000)
(defn- small-history? [{:keys [messages]}]
(<= (count (pr-str messages)) max-history-length))
(def HistoryMessage
"A message as the browser's own :chat :messages keeps it (see tbd.ui.db), not AG-UI's wire
Message: /api/chat/history is this app's own addition, not part of the AG-UI run protocol, so it
round-trips the client's fields as-is (kebab-case, a tool result's :name/:error?, and an
assistant reply's :thinking, for display, which AG-UI's Message has no place for) instead of
forcing them through Message's shape."
[:multi {:dispatch :role}
["user" [:map
[:role [:= "user"]]
[:content [:string {:min 1 :max max-message-length}]]]]
["assistant" [:and
[:map
[:role [:= "assistant"]]
[:content {:optional true} [:string {:max max-message-length}]]
[:thinking {:optional true} [:string {:max max-history-content-length}]]
;; the user halted the reply before it was over (see tbd.ui.events/::chat-halt)
[:halted? {:optional true} :boolean]
[:tool-calls {:optional true}
[:vector {:max max-tool-calls}
[:map
[:id Id]
[:name [:string {:min 1 :max 200}]]
[:arguments [:string {:max 100000}]]]]]]
[:fn (fn [{:keys [content tool-calls]}] (or (seq content) (seq tool-calls)))]]]
["tool" [:map
[:role [:= "tool"]]
[:tool-call-id Id]
[:name {:optional true} [:string {:max 200}]]
[:content [:string {:min 1 :max max-history-content-length}]]
[:error? {:optional true} :boolean]]]])
(def History
"The body of a PUT to /api/chat/history: the browser's whole conversation, oldest first."
[:and
[:map [:messages [:vector {:max max-history-messages} HistoryMessage]]]
[:fn small-history?]])
(defn page-of
"The `page` context entry's value, or nil."
[context]
(some #(when (= "page" (:description %)) (:value %)) context))
(defn ->internal-tool
"An AG-UI Tool as the MCP-style {:name :description :inputSchema} tbd.agent.core and
tbd.agent.json-schema expect."
[{:keys [name description parameters]}]
(cond-> {:name name :inputSchema (or parameters {})}
description (assoc :description description)))
(defn ->internal-message
"An AG-UI Message as tbd.agent.core's internal {:role :content :tool-calls :tool-call-id} (see
tbd.agent.core/llm-message)."
[{:keys [role content toolCalls toolCallId]}]
(cond-> {:role role :content content}
(seq toolCalls) (assoc :tool-calls
(mapv (fn [{:keys [id function]}]
{:id id :name (:name function) :arguments (:arguments function)})
toolCalls))
toolCallId (assoc :tool-call-id toolCallId)))
(defn system-text
"The agent's own system prompt for this run (see tbd.agent.instructions), never the caller's to
supply: only `page` (from `context`), `tools` and `state` shape it."
[{:keys [tools context state]}]
(instructions/chat-system-message (page-of context) tools state))
+295
View File
@@ -0,0 +1,295 @@
(ns tbd.chat.trace
"Observability for the chatbot's LLM turns: what the model was asked, how it went, and whether it
looks stuck. Called by tbd.agent.core and tbd.agent.a2a; no Ring or LLM code here.
One request to /api/chat, or one message to the A2A server, is one turn. A stuck agent is watched
for two ways: within a turn, reasoning that never ends (`:long-reasoning`) or repeats a sentence
(`:repeated-thinking`); across turns, the same tool call made over and over (`:repeated-call`).
A turn is one `tracer`: `begin!` logs `:turn-start`, `observe!` runs per reply event (logging
`:loop-suspect` and telling the caller to stop the turn once a loop is confirmed), `finish!` logs
`:turn-end` with the outcome, timings and flags. A tracer is for one thread.
Turns are correlated by `req` (per turn) and `run` (a hash of the user's last message, shared by
every turn of the tool loop it started), with `step` counting turns of the run from 0.
Entries go to a `sink`, which prints one `[tbd] chat <event> k=v ...` line and, if given a file,
appends it as JSON. Only the file gets the reasoning/reply text, the run's messages and the
system prompt — the user's words or the app's data — so that's off unless CHAT_TRACE_FILE is set
(tbd.agent.core/env-config)."
(:require [clojure.java.io :as io]
[clojure.string :as str]
[muuntaja.core :as m])
(: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 repeat-abort-count
"A sentence said this many times is not a false positive anymore: `observe!` says to stop the
turn. A milestone of `repeat-warn-count` (see `repeat-milestone?`), so it is always hit exactly,
not stepped over."
64)
(def long-reasoning-abort-chars
"Reasoning still going, without an answer or a call, at this many characters: `observe!` says to
stop the turn. A milestone of `reasoning-warn-chars` (each doubling), for the same reason."
32000)
(def ^:private max-distinct-sentences 5000)
(def ^:private max-pending-chars 1000)
(def ^:private max-args-length 500)
(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 (the map tbd.agent.core/observe! is
called with: any of :content, :thinking, :finish-reason, :usage)."
[state {:keys [content thinking call-deltas finish-reason usage]} now full?]
(let [state (cond-> (-> state
(update :events inc)
(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 :system-text})
(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, logging `:turn-start`. `messages`/`tools`/`page`/`model` are the
request's. `system-text` is the turn's system prompt; with `full-text?` on, it's also written to
the trace file. `trace` is a config from `config-for`, or nil for `default-config`. Returns the
tracer."
[trace {:keys [messages tools page model system-text]}]
(let [{:keys [sink full-text?]} (or trace default-config)
{:keys [run step run-calls top-call input]} (run-summary messages)
tracer {:sink sink :full-text? full-text?
: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 :system-text system-text)))
(when (and top-call (>= (:count top-call) repeated-call-warn-count))
(log! tracer :loop-suspect {:kind :repeated-call :tool (:tool top-call) :count (:count top-call)
:args (truncate (:args top-call) sample-length)}))
tracer))
(defn- abortable [alert]
(case (:kind alert)
:repeated-thinking (when (>= (:count alert) repeat-abort-count) alert)
:long-reasoning (when (>= (:chars alert) long-reasoning-abort-chars) alert)
nil))
(defn observe!
"Takes one event of the LLM's reply (tbd.agent.core/pump: :content, :thinking, or at the end
:finish-reason/:usage), logging `:loop-suspect` if the reasoning is running long or repeating.
Returns the alert to stop the turn over once it passes repeat-abort-count/long-reasoning-abort-chars,
else nil."
[{:keys [state full-text?] :as tracer} event]
(let [[state' alerts] (advance @state event (now-ms) full-text?)]
(reset! state (update state' :flags into (map :kind) alerts))
(doseq [alert alerts]
(log! tracer :loop-suspect alert))
(some abortable alerts)))
(defn finish!
"Ends the turn, logging `:turn-end`. Only the first call does anything, so it's safe to call
again in a `finally`. `outcome` is {:outcome :done|:tool-calls|:error|:upstream-error|:looped|:aborted
:calls [...] :error :detail}. :aborted is a turn that just stopped; :looped is one pump cut short
and retried (the retry is a turn of its own)."
[{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}]
(let [s @state]
(when-not (:finished? s)
(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)))))))))
+23 -15
View File
@@ -14,9 +14,13 @@
[reitit.ring.middleware.parameters :as parameters]
[muuntaja.core :as m]
[ring.util.response :as response]
[tbd.agent.a2a :as a2a]
[tbd.agent.core :as agent]
[tbd.auth.core :as auth]
[tbd.auth.middleware :as auth-mw]
[tbd.auth.routes :as auth-routes]
[tbd.chat.db :as chat-db]
[tbd.chat.routes :as chat-routes]
[tbd.health.routes :as health]
[tbd.http :as http]
[tbd.math.routes :as math]
@@ -25,6 +29,7 @@
[tbd.nrepl.routes :as nrepl-routes]
[tbd.oauth.db :as oauth-db]
[tbd.oauth.routes :as oauth-routes]
[tbd.sqlite :as sqlite]
[tbd.todo.db :as todo-db]
[tbd.todo.routes :as todo-routes]))
@@ -68,10 +73,9 @@
;; Each logical group (health, users, orders, ...) owns a `tbd.<group>.routes`
;; namespace that returns its own route subtree; they're concatenated here.
(defn make-router [{:keys [auth nrepl todo oauth webmcp]}]
(let [oauth-ds (delay (oauth-db/open (:db-path oauth)))
;; Opened (and migrated) on first use, not when the app loads.
todo-ds (delay (todo-db/open (:db-path todo)))]
(defn make-router [{:keys [auth nrepl db webmcp chat]}]
;; One database for every group's tables, opened (and migrated) on first use, not when the app loads.
(let [ds (delay (sqlite/open (:db-path db) todo-db/migrate! oauth-db/migrate! chat-db/migrate!))]
(ring/router
[["/swagger.json"
;; The spec is JSON, whatever the API default is (Swagger UI can't read EDN).
@@ -83,19 +87,19 @@
:handler (index-handler webmcp)}}]
(health/routes)
(math/routes)
(mcp-routes/routes auth oauth-ds todo-ds)
(oauth-routes/routes auth oauth-ds)
(mcp-routes/routes auth ds)
(a2a/routes auth ds chat)
(oauth-routes/routes auth ds)
(auth-routes/routes auth)
(chat-routes/routes chat ds)
(nrepl-routes/routes nrepl)
(todo-routes/routes todo-ds)]
(todo-routes/routes ds)]
{:data {:muuntaja http/muuntaja
:coercion malli/coercion
;; Handlers (and the auth/error middleware) return plain data; the muuntaja
;; middleware encodes it as the Accept header asks, so it wraps everything else.
;; Auth comes next, so unauthenticated callers to `:admin? true` / `:login? true`
;; routes are turned away before any body parsing or coercion runs. The request
;; half of muuntaja is split off below the exception middleware (rather than using the
;; combined format-middleware) so a malformed request body is caught and answered with a 400.
;; Order matters: response-formatting outermost (handlers return plain data), then
;; auth (so unauthenticated callers are turned away before body parsing/coercion),
;; then request-formatting split below the exception middleware so a malformed body
;; is caught and answered with a 400 rather than thrown.
:middleware [muuntaja-middleware/format-negotiate-middleware
muuntaja-middleware/format-response-middleware
(auth-mw/admin-middleware auth)
@@ -120,8 +124,8 @@
(def config
{:auth (auth/env-config)
:nrepl (nrepl/env-config)
:todo (todo-db/env-config)
:oauth (oauth-db/env-config)
:chat (agent/env-config)
:db (sqlite/env-config)
:webmcp {:origin-trial-token (some-> (System/getenv "WEBMCP_ORIGIN_TRIAL_TOKEN") str/trim not-empty)}})
(def app (make-app config))
@@ -141,6 +145,10 @@
(println "[tbd] WARNING: ADMIN_USERS is empty; nobody can use the admin API"))
(when-not (get-in config [:auth :session-secret])
(println "[tbd] WARNING: SESSION_SECRET is not set; logins won't survive a restart"))
(when-not (agent/configured? (:chat config))
(println "[tbd] LMSTUDIO_URL is not set; the chatbot is unavailable"))
(when-let [file (get-in config [:chat :trace :file])]
(println (str "[tbd] chat: tracing every turn, reasoning and replies included, to " file)))
(try
(let [server (jetty/run-jetty (wrap-defaults app api-defaults)
{:port port
+5 -5
View File
@@ -18,9 +18,9 @@
(defn make-handler
"A Ring handler speaking MCP over Streamable HTTP, for callers with a valid access token
(`auth` is the auth config, `ds` a delay of the OAuth database, `todo-ds` one of the todo database). It keeps its MCP sessions in
(`auth` is the auth config, `ds` a delay of the app's database). It keeps its MCP sessions in
memory, so each handler is its own server: sessions don't outlive it, and aren't shared between nodes."
[auth ds todo-ds]
[auth ds]
(let [{:keys [runtime jsonrpc-handler] :as options}
(mcp-server/make-server-options
{:info (es/make-info "tbd" "1.0.0" "tbd MCP server")
@@ -29,14 +29,14 @@
:traffic-logger traffic-logger/nop-traffic-logger})]
(-> (mcp-http/make-ring-handler runtime jsonrpc-handler options)
;; What the tools that touch todos need besides the caller (see tbd.mcp.tools).
(wrap-runtime {tools/todo-ds-key todo-ds})
(wrap-runtime {tools/ds-key ds})
;; Jetty hands over the body as a stream; plumcp reads the message through `:on-msg`.
mcp-http/wrap-request-body-reader
;; Outermost, so a request without a token is turned away before its body is read.
(oauth-mw/wrap-bearer-auth auth ds))))
(defn routes [auth ds todo-ds]
(let [handler (make-handler auth ds todo-ds)]
(defn routes [auth ds]
(let [handler (make-handler auth ds)]
["/mcp"
;; plumcp does its own content negotiation, JSON parsing and (via the wrapper above) body
;; reading, so it must not sit behind the API's muuntaja/coercion middleware chain. ^:replace
+10 -10
View File
@@ -18,10 +18,10 @@
[tbd.todo.schema :as todo-schema]
[tbd.todo.service :as todo]))
(def todo-ds-key
"Where the todo database (a delay, as for the HTTP routes) is in the request's plumcp runtime
bag; tbd.mcp.routes puts it there."
:tbd/todo-ds)
(def ds-key
"Where the database (a delay, as for the HTTP routes) is in the request's plumcp runtime bag;
tbd.mcp.routes puts it there."
:tbd/ds)
(defn- current-user
"Who is calling: {:login :id :admin? :client-id}, the user whose access token the request
@@ -39,7 +39,7 @@
(if error (throw (ex-info error {})) ok))
;; Todos belong to the caller, and tbd.todo.service scopes every operation to them.
(defn- todo-ds [ctx] (ctx-get ctx todo-ds-key))
(defn- ds [ctx] (ctx-get ctx ds-key))
(def primitives
{:tools
@@ -55,20 +55,20 @@
(format "%s (Gitea user %d)%s" login id (if admin? ", admin" "")))))
(tool "list_todos" "Lists your todos (JSON: id, title, done, created-at, updated-at), oldest first" [:map]
(fn [_ ctx] (->json (ok! (todo/list-todos (todo-ds ctx) (current-user ctx))))))
(fn [_ ctx] (->json (ok! (todo/list-todos (ds ctx) (current-user ctx))))))
(tool "get_todo" "Gets one of your todos by id (JSON)" todo-schema/IdParam
(fn [{:keys [id]} ctx] (->json (ok! (todo/find-todo (todo-ds ctx) (current-user ctx) id)))))
(fn [{:keys [id]} ctx] (->json (ok! (todo/find-todo (ds ctx) (current-user ctx) id)))))
(tool "create_todo" "Creates a todo for you and returns it (JSON)" todo-schema/NewTodo
(fn [{:keys [title]} ctx] (->json (ok! (todo/create! (todo-ds ctx) (current-user ctx) title)))))
(fn [{:keys [title]} ctx] (->json (ok! (todo/create! (ds ctx) (current-user ctx) title)))))
(tool "update_todo" "Changes the title and/or done flag of one of your todos and returns it (JSON)"
todo-schema/UpdateTodo
(fn [{:keys [id] :as input} ctx]
(->json (ok! (todo/update! (todo-ds ctx) (current-user ctx) id (dissoc input :id))))))
(->json (ok! (todo/update! (ds ctx) (current-user ctx) id (dissoc input :id))))))
(tool "delete_todo" "Deletes one of your todos" todo-schema/IdParam
(fn [{:keys [id]} ctx]
(ok! (todo/delete! (todo-ds ctx) (current-user ctx) id))
(ok! (todo/delete! (ds ctx) (current-user ctx) id))
"deleted"))]})
+29 -37
View File
@@ -1,23 +1,31 @@
(ns tbd.oauth.db
"SQLite persistence for the MCP OAuth server, in a local file. Storage only: what is valid, and
"SQLite persistence for the MCP OAuth server, in the app's database (see tbd.sqlite). Storage only: what is valid, and
when, lives in tbd.oauth.core and tbd.oauth.routes. Codes and tokens are stored as hashes
(see tbd.oauth.core/hash-token), so callers pass hashes here, never the secrets themselves."
(:require [clojure.edn :as edn]
[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")
;; 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 env-config
"OAUTH_DB_PATH: where the SQLite file lives (default data/oauth.db; its directory is created)."
([] (env-config (System/getenv)))
([env]
(let [path (get env "OAUTH_DB_PATH")]
{:db-path (if (str/blank? path) default-path (str/trim path))})))
(defn- migrate! [ds]
(defn migrate!
"Creates the OAuth tables in the database `ds`, or brings them up to date."
[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 (
id TEXT PRIMARY KEY,
@@ -34,31 +42,15 @@
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
"A datasource for the database file at `path`, created and migrated if need be; connections
and locking work as in tbd.todo.db."
"A database with just the OAuth tables, at `path`; the app opens one with every group's tables
(see tbd.core), which this is for tests of the group on its own."
[path]
(when (str/blank? path)
(throw (ex-info "no OAuth database path configured (set OAUTH_DB_PATH)" {})))
(some-> (io/file path) .getAbsoluteFile .getParentFile .mkdirs)
(doto (jdbc/get-datasource {:dbtype "sqlite" :dbname path
:journal_mode "WAL" :busy_timeout 5000})
migrate!))
(sqlite/open path migrate!))
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
@@ -107,10 +99,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
+1 -1
View File
@@ -303,7 +303,7 @@
(token-error "unsupported_grant_type" "grant_type must be authorization_code or refresh_token"))))
(defn routes
"`ds` is a delay of the datasource (see tbd.oauth.db/open), so the database isn't touched until needed."
"`ds` is a delay of the datasource (see tbd.sqlite/open), so the database isn't touched until needed."
[config ds]
(let [guarded #(only-when-configured config %)]
["" {:no-doc true
+62
View File
@@ -0,0 +1,62 @@
(ns tbd.sqlite
"The app's one SQLite database, which every group with storage (tbd.todo.db, tbd.oauth.db)
keeps its tables in: where it lives, opening it, the ids of the rows the groups own, and
moving a table off the integer ids it used to have."
(:require [clojure.java.io :as io]
[clojure.string :as str]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]))
(def default-path "data/tbd.db")
(defn env-config
"DB_PATH: where the SQLite file lives (default data/tbd.db; its directory is created)."
([] (env-config (System/getenv)))
([env]
(let [path (get env "DB_PATH")]
{:db-path (if (str/blank? path) default-path (str/trim path))})))
(defn open
"A datasource for the database file at `path`, created if need be and migrated by each of
`migrations` (fns of the datasource, each creating and updating a group's own tables). Each
query opens its own connection (cheap for a local file); WAL mode plus a busy timeout let
concurrent requests wait on each other's writes instead of failing."
[path & migrations]
(when (str/blank? path)
(throw (ex-info "no database path configured (set DB_PATH)" {})))
(some-> (io/file path) .getAbsoluteFile .getParentFile .mkdirs)
(let [ds (jdbc/get-datasource {:dbtype "sqlite" :dbname path
:journal_mode "WAL" :busy_timeout 5000})]
(run! #(% ds) migrations)
ds))
(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))))))))
+31 -37
View File
@@ -1,42 +1,34 @@
(ns tbd.todo.db
"SQLite persistence for the todo group, in a local file. Storage only: validation and other
"SQLite persistence for the todo group, in the app's database (see tbd.sqlite). Storage only: validation and other
rules live in tbd.todo.core. Every query takes an `owner-id` and filters on it, so one
user's todos can't be read or changed through another user's ids."
(:require [clojure.java.io :as io]
[clojure.string :as str]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]))
(:require [next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def default-path "data/todo.db")
(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 env-config
"TODO_DB_PATH: where the SQLite file lives (default data/todo.db; its directory is created)."
([] (env-config (System/getenv)))
([env]
(let [path (get env "TODO_DB_PATH")]
{:db-path (if (str/blank? path) default-path (str/trim path))})))
(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)"]))
(defn migrate!
"Creates the todo tables in the database `ds`, or brings them up to date."
[ds]
(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
opens its own connection (cheap for a local file); WAL mode plus a busy timeout let
concurrent requests wait on each other's writes instead of failing."
"A database with just the todo tables, at `path`; the app opens one with every group's tables
(see tbd.core), which this is for tests of the group on its own."
[path]
(when (str/blank? path)
(throw (ex-info "no todo database path configured (set TODO_DB_PATH)" {})))
(some-> (io/file path) .getAbsoluteFile .getParentFile .mkdirs)
(doto (jdbc/get-datasource {:dbtype "sqlite" :dbname path
:journal_mode "WAL" :busy_timeout 5000})
migrate!))
(sqlite/open path migrate!))
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
@@ -45,17 +37,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)."
+1 -1
View File
@@ -39,7 +39,7 @@
(reply 200 (fn [_] {:deleted true}) (service/delete! ds user id))))
(defn routes
"`ds` is a delay of the todo database (see tbd.todo.db/open), shared with the MCP tools."
"`ds` is a delay of the app's database (see tbd.sqlite/open), shared with the MCP tools."
[ds]
(let [id-param {:path schema/IdParam}]
["/api/todos"
+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"
+1 -1
View File
@@ -5,7 +5,7 @@
same on both and are written (and tested) once. A front end only translates: its request into
arguments, and the result into a response.
`ds` is the delay of the todo database the app shares (opened on first use, so a caller who is
`ds` is the delay of the database the app shares (opened on first use, so a caller who is
turned away earlier never opens it). `user` is the authenticated caller, {:id ...} at least
(however they proved who they are: a session or an access token); a todo is only ever reached
through its owner's id, and someone else's is reported exactly like a missing one.
+94
View File
@@ -0,0 +1,94 @@
(ns tbd.agent.a2a-test
(:require [clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[tbd.agent.test-support :as ts]
[tbd.auth.routes-test :as t]
[tbd.oauth.core :as oauth]
[tbd.oauth.db :as db]
[tbd.sqlite-test :as sqlite-test])
(:import (java.io ByteArrayInputStream)))
;; A2A sits behind its own transport, like /mcp, so these go through the real app (tbd.core) and
;; speak JSON-RPC to /a2a the way an A2A client does, with an OAuth access token.
(defn- mint-token!
[path login id]
(let [token (oauth/random-token)
expires-at (+ (System/currentTimeMillis) 60000)]
(db/insert-grant! (db/open path) {:client-id "test-client" :user-id id :login login :scope "mcp"
:access-hash (oauth/hash-token token) :access-expires-at expires-at
:refresh-hash (oauth/hash-token (oauth/random-token))
:refresh-expires-at expires-at :created-at 1})
token))
(defn- rpc [app token message]
(let [body (slurp (m/encode "application/json" message))
resp (app {:request-method :post :uri "/a2a"
:headers (cond-> {"content-type" "application/json"}
token (assoc "authorization" (str "Bearer " token)))
:body (ByteArrayInputStream. (.getBytes ^String body))})]
(update resp :body #(when % (m/decode "application/json" %)))))
(defn- app-with [chat & {:keys [db-path] :or {db-path (sqlite-test/temp-db-path)}}]
[(t/make-app (t/gitea-stub "alice") :chat chat :db {:db-path db-path}) db-path])
(defn- send-message [text]
{:jsonrpc "2.0" :id 1 :method "message/send"
:params {:message {:role "user" :parts [{:kind "text" :text text}] :messageId "m1" :kind "message"}}})
(deftest agent-card-test
(let [[app] (app-with (ts/config (ts/text-model "hi")))
resp (app {:request-method :get :uri "/.well-known/agent-card.json"})]
(is (= 200 (:status resp)))
(let [card (m/decode "application/json" (:body resp))]
(is (= "tbd" (:name card)))
(is (= "http://tbd.test/a2a" (:url card)))
(is (false? (get-in card [:capabilities :streaming])))
(is (contains? (:securitySchemes card) :bearer))
(is (some #(= "add" (:id %)) (:skills card))))))
(deftest message-send-test
(let [[app path] (app-with (ts/config (ts/text-model "Hi there")))
token (mint-token! path "alice" 7)
resp (rpc app token (send-message "hi"))]
(is (= 200 (:status resp)))
(is (= "2.0" (get-in resp [:body :jsonrpc])))
(is (= 1 (get-in resp [:body :id])))
(is (= "agent" (get-in resp [:body :result :role])))
(is (= "Hi there" (get-in resp [:body :result :parts 0 :text])))))
(deftest unauthorized-test
(let [[app] (app-with (ts/config (ts/text-model "x")))]
(is (= 401 (:status (rpc app nil (send-message "hi")))))
(is (= 401 (:status (rpc app "not-a-real-token" (send-message "hi")))))))
(deftest tool-loop-test
(testing "the agent's own tool calls are run immediately, server-side, and the loop continues
until it answers in text"
(let [[app path] (app-with (ts/config (ts/tool-call-model {:id "c1" :name "add" :arguments "{\"x\":1,\"y\":2}"})))
token (mint-token! path "alice" 7)]
;; tool-call-model always asks for the same call; run-tools! must give up rather than loop forever
(is (= 502 (:status (rpc app token (send-message "add 1 and 2"))))))))
(deftest tool-loop-runs-a-real-tool-test
;; A regression test for the tool handlers themselves (create_todo etc. return JSON via
;; tbd.agent.a2a/->json): the first turn asks for a call, the second answers from its result.
(let [turn (atom 0)
first-model (ts/tool-call-model {:id "c1" :name "create_todo" :arguments "{\"title\":\"milk\"}"})
second-model (ts/text-model "Added it.")
model (ts/model-of
(fn [req handler]
(if (zero? @turn)
(do (swap! turn inc) (.doChat first-model req handler))
(.doChat second-model req handler))))
[app path] (app-with (ts/config model))
token (mint-token! path "alice" 7)
resp (rpc app token (send-message "add a todo to buy milk"))]
(is (= 200 (:status resp)))
(is (= "Added it." (get-in resp [:body :result :parts 0 :text])))))
(deftest invalid-jsonrpc-test
(let [[app path] (app-with (ts/config (ts/text-model "x")))
token (mint-token! path "alice" 7)]
(is (= "invalid JSON-RPC request" (get-in (rpc app token {:id 1 :method "message/send"}) [:body :error :message])))
(is (= "method not found: nope" (get-in (rpc app token {:jsonrpc "2.0" :id 1 :method "nope"}) [:body :error :message])))))
+110
View File
@@ -0,0 +1,110 @@
(ns tbd.agent.core-test
(:require [clojure.test :refer [deftest is testing]]
[tbd.agent.core :as agent]
[tbd.agent.test-support :as ts]
[tbd.chat.trace :as trace])
(:import (dev.langchain4j.data.message AiMessage SystemMessage)
(dev.langchain4j.model.chat.request ChatRequest)
(dev.langchain4j.model.chat.response PartialResponse PartialResponseContext
PartialThinking PartialThinkingContext)
(dev.langchain4j.model.output FinishReason)))
(defn- turn! [config messages tools]
(let [{:keys [ok error kind]} (agent/start config "system prompt" messages tools)]
(if error
{:error error :kind kind}
(let [events (atom [])]
(ok (fn [e] (swap! events conj e)))
{:events @events}))))
(deftest not-configured
(is (= {:error "chat is not configured" :kind :unavailable}
(agent/start {} "sys" [{:role "user" :content "hi"}] nil))))
(deftest api-base-url-adds-v1
(testing "LM Studio's OpenAI-compatible endpoints live under /v1, which LangChain4j does not add
on its own (see tbd.agent.core/api-base-url); LMSTUDIO_URL is documented as the bare
server address, so this has to be added for every request to land"
(is (= "http://llm.test/v1" (#'agent/api-base-url "http://llm.test")))
(is (= "http://llm.test/v1" (#'agent/api-base-url "http://llm.test/v1")))))
(deftest a-plain-reply
(is (= {:events [{:thinking "hm"} {:content "Hel"} {:content "lo"} {:done true}]}
(turn! (ts/config (ts/thinking-model "hm" "Hel" "lo")) [{:role "user" :content "hi"}] nil))))
(deftest a-tool-call
(is (= {:events [{:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":1}"}]} {:done true}]}
(turn! (ts/config (ts/tool-call-model {:id "call_1" :name "add" :arguments "{\"x\":1}"}))
[{:role "user" :content "add 1"}]
[{:name "add" :description "adds" :inputSchema {:type "object" :properties {}}}]))))
(deftest no-reply-is-an-error
(is (= {:events [{:error "the LLM server sent no reply"}]}
(turn! (ts/config (ts/no-reply-model)) [{:role "user" :content "hi"}] nil))))
(deftest tools-optional
(is (= {:events [{:content "x"} {:done true}]}
(turn! (ts/config (ts/text-model "x")) [{:role "user" :content "hi"}] nil))))
(deftest connection-failure-is-caught-before-the-stream-starts
(testing "the model errors before ever saying anything: {:error}, no {:ok}"
(is (= {:error "the LLM server can't be reached or refused" :kind :upstream}
(turn! (ts/config (ts/error-model "boom")) [{:role "user" :content "hi"}] nil))))
(testing "the fake model itself throws synchronously"
(let [config (ts/config (ts/model-of (fn [_ _] (throw (RuntimeException. "no such host")))))]
(is (= :upstream (:kind (turn! config [{:role "user" :content "hi"}] nil))))))
(testing ".chat is never called when chat isn't configured, whatever the model would have said"
(let [calls (atom 0)
config (assoc (ts/config (ts/model-of (fn [_ _] (swap! calls inc)))) :url nil)]
(is (= {:error "chat is not configured" :kind :unavailable} (turn! config [] nil)))
(is (zero? @calls)))))
(deftest a-loop-is-retried-once-then-recovers
(testing "a turn that repeats itself is cut short and sent again, nudged to answer; the retry's
reply is what the caller sees, not a failure"
(let [calls (atom 0)
reqs (atom [])
sentence "Wait, let me check the board again. "
model (ts/model-of
(fn [req handler]
(swap! reqs conj req)
(let [h (ts/fake-handle)]
(if (= 1 (swap! calls inc))
(dotimes [_ trace/repeat-abort-count]
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h)))
(do (.onPartialResponse handler (PartialResponse. "ok") (PartialResponseContext. h))
(ts/complete handler (AiMessage/from "ok") FinishReason/STOP [10 5]))))))
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
(is (= 2 @calls) "the model is asked again, once, after the loop")
(is (= [{:content "ok"} {:done true}] (take-last 2 events))
"the retry's reply is what the caller ends up seeing")
(is (= trace/repeat-abort-count (count (filter #(= {:thinking sentence} %) events)))
"the caller still sees what the model was thinking before it was cut off")
(is (not-any? :error events) "a loop that recovers is not shown to the user as a failure")
(is (not (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (first @reqs))))))
"the first attempt's prompt is unchanged")
(is (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (second @reqs)))))
"the retry's prompt has the nudge appended"))))
(deftest a-loop-that-does-not-recover-is-an-error
(testing "only one retry is made: a turn that loops again on the retry is finally an error"
(let [calls (atom 0)
sentence "Wait, let me check the board again. "
model (ts/model-of
(fn [_ handler]
(swap! calls inc)
(let [h (ts/fake-handle)]
(dotimes [_ trace/repeat-abort-count]
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h))))))
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
(is (= 2 @calls) "the retry itself is not retried again")
(is (= {:error "the model got stuck repeating itself, and the reply was stopped"} (last events))))))
(deftest conversation-history-round-trips
(testing "assistant messages with tool calls, and their tool-role results, reach the model
without error (see tbd.agent.core/llm-message)"
(let [messages [{:role "user" :content "add 1 and 2"}
{:role "assistant" :content "" :tool-calls [{:id "c1" :name "add" :arguments "{\"x\":1,\"y\":2}"}]}
{:role "tool" :tool-call-id "c1" :content "3"}]]
(is (= {:events [{:content "3"} {:done true}]}
(turn! (ts/config (ts/text-model "3")) messages nil))))))
+49
View File
@@ -0,0 +1,49 @@
(ns tbd.agent.instructions-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is]]
[tbd.agent.instructions :as instructions]
[tbd.agent.prompt :as prompt]))
(defn- flat
"`text` on one line: the prompts are wrapped in the source, where they wrap is not the point."
[text]
(str/replace text #"\s+" " "))
(deftest chat-and-guide-share-the-instructions
(doseq [text (map flat [(instructions/chat) prompt/guide])]
(is (str/includes? text "Act, don't offer"))
(is (str/includes? text "in this same turn"))
(is (str/includes? text "Work it out yourself:"))
(is (str/includes? text "Say something was done only if a tool result says it was"))
(is (str/includes? text "Examples: "))))
(deftest chat-is-framed-as-the-in-page-chatbot
(let [text (instructions/chat)]
(is (str/includes? text "under your message"))
(is (str/includes? text "Chain calls without stopping"))
(is (str/includes? text "navigate there, then") "the chatbot's tools follow the page it is on")
(is (str/includes? (flat text) "\"Current state of the page\" below")
"it's told where to find what a read tool used to be for")
(is (not (str/includes? text "list_todos")) "it has no list_todos: the state has that")
(is (not (str/includes? text "get_tic_tac_toe")) "nor get_tic_tac_toe")))
(deftest chat-system-message-adds-page-and-tools
(is (= (instructions/chat) (instructions/chat-system-message nil nil nil)))
(let [text (instructions/chat-system-message "todos" [{:name "create_todo"} {:name "list_todos"}] nil)]
(is (str/includes? text "on the \"todos\" page"))
(is (str/includes? text "Its tools: create_todo, list_todos"))))
(deftest chat-system-message-adds-state
(is (= (instructions/chat) (instructions/chat-system-message nil nil {})) "empty state adds nothing")
(let [text (instructions/chat-system-message nil nil {:todos [{:title "milk" :done false}]})]
(is (str/includes? text "Current state of the page"))
(is (str/includes? text "never call a tool just to read it"))
(is (str/includes? text "\"title\":\"milk\""))))
(deftest a2a-has-no-in-page-framing
(let [text (instructions/a2a)]
(is (str/includes? text "Act, don't offer"))
(is (str/includes? text "Agent2Agent protocol"))
(is (str/includes? text "no page open"))
(is (not (str/includes? text "under your message")))
(is (str/includes? text "list_todos -> set_todo_done") "it has no state either: it reads first, like WebMCP's guide")))
+44
View File
@@ -0,0 +1,44 @@
(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 guide-tells-the-agent-to-act
(let [text (flat prompt/guide)]
(is (str/includes? text "Act, don't offer"))
(is (str/includes? text "in this same turn"))
(is (str/includes? text "Work it out yourself:"))
(is (str/includes? text "Chain calls without stopping"))
(is (str/includes? text "an earlier one may no longer hold"))
(is (str/includes? text "never go by an earlier result"))
(is (str/includes? text "Say something was done only if a tool result says it was"))
(is (str/includes? text "Examples: "))
(is (not (str/includes? text "navigate there, then")) "an outside agent is offered every tool")))
(deftest task-prompt
(is (str/starts-with? (prompt/task "add a todo") prompt/guide))
(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 examples-differ-by-reads
(testing "an outside agent (no state channel) is shown reading first"
(is (str/includes? (prompt/examples true) "list_todos -> set_todo_done"))
(is (str/includes? (prompt/examples true) "list_todos -> ONE set_todo_done")))
(testing "the chatbot (state already in view) is not, since it has no list_todos"
(is (not (str/includes? (prompt/examples false) "list_todos"))))
(testing "the rest is the same either way"
(doseq [text [(prompt/examples true) (prompt/examples false)]]
(is (str/includes? text "create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\""))
(is (str/includes? text "add{\"x\":19,\"y\":4} -> \"23.\"")))))
(deftest tic-tac-toe-prompt
(is (str/includes? prompt/tic-tac-toe "get_tic_tac_toe and move_tic_tac_toe"))
(is (not (str/includes? prompt/tic-tac-toe "as X")) "no side is assigned by the prompt")
(is (not (str/includes? prompt/tic-tac-toe "as O")) "no side is assigned by the prompt"))
+92
View File
@@ -0,0 +1,92 @@
(ns tbd.agent.test-support
"A fake LangChain4j StreamingChatModel for tests: no real network, no LM Studio. `model-of`
builds one from a script — a function of the ChatRequest that calls the handler's callbacks
directly, exactly as a real provider's client would, so tbd.agent.core's pump code is exercised
for real. `text-model`/`tool-call-model`/`error-model`/`thinking-model` cover the common cases."
(:require [tbd.agent.core :as agent])
(:import (dev.langchain4j.agent.tool ToolExecutionRequest)
(dev.langchain4j.data.message AiMessage)
(dev.langchain4j.model.chat StreamingChatModel)
(dev.langchain4j.model.chat.response
ChatResponse ChatResponseMetadata$Builder CompleteToolCall PartialResponse
PartialResponseContext PartialThinking PartialThinkingContext StreamingHandle)
(dev.langchain4j.model.output FinishReason TokenUsage)))
(defn fake-handle
"A StreamingHandle whose `cancel` is observable through the atom `cancelled?`."
([] (fake-handle (atom false)))
([cancelled?]
(reify StreamingHandle
(cancel [_] (reset! cancelled? true))
(isCancelled [_] @cancelled?))))
(defn model-of
"A StreamingChatModel whose `doChat` calls `(script req handler)`."
^StreamingChatModel [script]
(reify StreamingChatModel
(doChat [_ req handler] (script req handler) nil)))
(defn complete
"Finishes a fake model's call: sends `handler` an onCompleteResponse of `ai-message`, with
`finish-reason` and `usage` ([prompt completion], or nil for neither) — for a test whose fake
model needs more control than text-model/tool-call-model/etc give."
[handler ai-message finish-reason usage]
(.onCompleteResponse handler
(-> (ChatResponse/builder)
(.aiMessage ai-message)
(.metadata (cond-> (ChatResponseMetadata$Builder.)
finish-reason (.finishReason finish-reason)
usage (.tokenUsage (TokenUsage. (int (first usage)) (int (second usage))))
true .build))
.build)))
(defn text-model
"A model that streams `pieces` as :content, then finishes with their concatenation as the reply."
[& pieces]
(model-of (fn [_ handler]
(let [h (fake-handle)]
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn text-model-capturing
"Like text-model, but `(reset! captured req)` with the ChatRequest sent — for a test that checks
what went into the system prompt (tbd.agent.instructions/chat-system-message), tools, or history."
[captured & pieces]
(model-of (fn [req handler]
(reset! captured req)
(let [h (fake-handle)]
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn thinking-model
"A model that streams `thinking`, then `pieces` as content."
[thinking & pieces]
(model-of (fn [_ handler]
(let [h (fake-handle)]
(.onPartialThinking handler (PartialThinking. ^String thinking) (PartialThinkingContext. h))
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn tool-call-model
"A model that asks for one tool call: {:id :name :arguments}."
[{:keys [id name arguments]}]
(model-of (fn [_ handler]
(let [req (-> (ToolExecutionRequest/builder) (.id id) (.name name) (.arguments arguments) .build)]
(.onCompleteToolCall handler (CompleteToolCall. (int 0) req))
(complete handler (AiMessage/from "" [req]) FinishReason/TOOL_EXECUTION nil)))))
(defn error-model
"A model whose call always fails with `message`."
[message]
(model-of (fn [_ handler] (.onError handler (RuntimeException. ^String message)))))
(defn no-reply-model
"A model that ends the turn with nothing said and no calls (the LLM sent no reply)."
[]
(model-of (fn [_ handler] (complete handler (AiMessage/from "") FinishReason/STOP nil))))
(defn config
"A chat config (see tbd.agent.core/env-config) using `model` instead of a real LM Studio."
([model] (config model {}))
([model overrides]
(merge (agent/env-config {"LMSTUDIO_URL" "http://llm.test"}) {:chat-model model} overrides)))
+5 -5
View File
@@ -15,10 +15,10 @@
(str/ends-with? url "/api/v1/user") {:status 200 :body (format "{\"login\":\"%s\",\"id\":%d}" login id)}))))
(defn make-app
"The app against a Gitea stub. `:todo` and `:oauth` (their configs) are passed through; other overrides go into the auth config."
[http & {:keys [todo oauth] :as overrides}]
(core/make-app {:todo todo
:oauth oauth
"The app against a Gitea stub. `:db` and `:chat` (their configs) are passed through; other overrides go into the auth config."
[http & {:keys [db chat] :as overrides}]
(core/make-app {:db db
:chat chat
:auth (merge {:base-url "http://tbd.test"
:gitea-url "https://gitea.test"
:client-id "cid"
@@ -28,7 +28,7 @@
:session-secret "test-secret"
:secure-cookies? false
:http http}
(dissoc overrides :todo :oauth))
(dissoc overrides :db :chat))
:nrepl {:port 0 :bind "127.0.0.1"}}))
(defn request [app method uri & {:keys [cookie query]}]
+43
View File
@@ -0,0 +1,43 @@
(ns tbd.chat.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[tbd.chat.db :as db]
[tbd.sqlite-test :refer [temp-db-path]]))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
(db/open path)
(is (.exists (io/file path)))))
(testing "reopening keeps the data"
(let [path (temp-db-path)
messages [{:role "user" :content "hi"}]]
(db/save-history! (db/open path) 7 messages 1000)
(is (= messages (db/get-history (db/open path) 7))))))
(deftest crud-test
(let [ds (db/open (temp-db-path))]
(testing "nothing stored yet"
(is (= [] (db/get-history ds 7))))
(testing "save and load"
(db/save-history! ds 7 [{:role "user" :content "hi"}] 1000)
(is (= [{:role "user" :content "hi"}] (db/get-history ds 7))))
(testing "saving again replaces the whole conversation"
(db/save-history! ds 7 [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}]
2000)
(is (= [{:role "user" :content "hi"} {:role "assistant" :content "hello"}]
(db/get-history ds 7))))
(testing "clear"
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7))))))
(deftest owner-scoping-test
(let [ds (db/open (temp-db-path))]
(db/save-history! ds 7 [{:role "user" :content "mine"}] 1000)
(db/save-history! ds 8 [{:role "user" :content "theirs"}] 1000)
(is (= [{:role "user" :content "mine"}] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)))
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)) "clearing one owner's history leaves the other's")))
+269
View File
@@ -0,0 +1,269 @@
(ns tbd.chat.routes-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[ring.core.protocols :as ring-protocols]
[tbd.agent.test-support :as ts]
[tbd.auth.routes-test :as t]
[tbd.sqlite-test :as sqlite-test]
[tbd.test-util :as test-util])
(:import (dev.langchain4j.data.message SystemMessage)
(dev.langchain4j.model.chat.request ChatRequest)
(java.io ByteArrayInputStream ByteArrayOutputStream IOException OutputStream)))
(defn- json [data] (slurp (m/encode "application/json" data)))
(defn- post-chat
"POST /api/chat with `body`, a JSON string (or nil for none)."
[app cookie body]
(test-util/decode-body
(app (cond-> {:request-method :post :uri "/api/chat"
:headers (cond-> {"content-type" "application/json"}
cookie (assoc "cookie" cookie))}
body (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))))))
(defn- body-text
"What a response's streaming body writes, as the server would write it to the browser."
[resp]
(let [out (ByteArrayOutputStream.)]
(ring-protocols/write-body-to-stream (:body resp) resp out)
(.toString out "UTF-8")))
(defn- events
"The AG-UI events of a chat response: the JSON of each `data:` line, `:type` and one message/call
id dropped (a random uuid, not what these tests are about) unless a test keeps it."
[resp]
(->> (str/split (body-text resp) #"\n\n")
(map #(m/decode "application/json" (str/replace-first % "data: " "")))))
(defn- types [resp] (map :type (events resp)))
(def ^:private hello (json {:messages [{:id "m1" :role "user" :content "hi"}]}))
(defn- app-with
([chat] (app-with chat "alice" 7 (sqlite-test/temp-db-path)))
([chat login id db-path]
(t/make-app (t/gitea-stub login id) :chat chat :db {:db-path db-path})))
(defn- request
"`body` is EDN data (or nil), sent (and the response read) as EDN, like the browser does."
[app method uri cookie & [body]]
(test-util/decode-body
(app (cond-> {:request-method method :uri uri
:headers (cond-> {} cookie (assoc "cookie" cookie))}
body (-> (assoc :body (ByteArrayInputStream. (.getBytes ^String (pr-str body))))
(assoc-in [:headers "content-type"] "application/edn"))))))
(deftest anonymous-test
(let [app (app-with (ts/config (ts/text-model "x")))]
(doseq [body [hello "nope" nil]]
(let [resp (post-chat app nil body)]
(is (= 401 (:status resp)))
(is (= {:error "login required"} (:body resp)))))))
(deftest chat-test
(let [app (app-with (ts/config (ts/text-model "Hello" ", Alice")))
cookie (t/login! app)]
(testing "the reply streams back as AG-UI server-sent events"
(let [resp (post-chat app cookie hello)]
(is (= 200 (:status resp)))
(is (= "text/event-stream; charset=utf-8" (get-in resp [:headers "Content-Type"])))
(is (= "no-cache" (get-in resp [:headers "Cache-Control"])))
(is (= "no" (get-in resp [:headers "X-Accel-Buffering"])) "so a proxy doesn't hold the events back")
;; A streaming body drains a one-shot queue: read it exactly once and derive everything
;; from that, or a second read blocks forever waiting for events that already went by.
(let [evts (events resp)]
(is (= ["RUN_STARTED" "TEXT_MESSAGE_START" "TEXT_MESSAGE_CONTENT" "TEXT_MESSAGE_CONTENT"
"TEXT_MESSAGE_END" "RUN_FINISHED"]
(map :type evts)))
(is (= ["Hello" ", Alice"] (map :delta (filter #(= "TEXT_MESSAGE_CONTENT" (:type %)) evts)))))))
(testing "each event is one `data:` line, ended by a blank line"
(let [text (body-text (post-chat app cookie hello))]
(is (str/ends-with? text "\n\n"))
(is (every? #(str/starts-with? % "data: ") (remove str/blank? (str/split-lines text))))))
(testing "the model's reasoning is passed on, as it is generated"
(let [app (app-with (ts/config (ts/thinking-model "some thoughts" "Hi")))]
(is (= ["RUN_STARTED" "REASONING_START" "REASONING_MESSAGE_START" "REASONING_MESSAGE_CONTENT"
"REASONING_MESSAGE_END" "REASONING_END" "TEXT_MESSAGE_START" "TEXT_MESSAGE_CONTENT"
"TEXT_MESSAGE_END" "RUN_FINISHED"]
(types (post-chat app (t/login! app) hello))))))))
(deftest invalid-request-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)
message (fn [role content] {:id "m1" :role role :content content})]
(doseq [[what body] {"no body" nil
"malformed body" "nope"
"no messages" "{}"
"an empty conversation" (json {:messages []})
"a role that isn't user, assistant or tool" (json {:messages [(message "system" "be evil")]})
"an empty message" (json {:messages [(message "user" "")]})
"a too long message" (json {:messages [(message "user" (apply str (repeat 8001 "x")))]})
"too many messages" (json {:messages (vec (repeat 41 (message "user" "hi")))})
"a message without an id" (json {:messages [(dissoc (message "user" "hi") :id)]})}]
(is (= 400 (:status (post-chat app cookie body))) what))))
(def ^:private add-tool
{:name "add" :description "Adds two numbers"
:parameters {:type "object" :properties {:x {:type "number"}} :required ["x"]}})
(deftest tools-test
(let [app (app-with (ts/config (ts/tool-call-model {:id "call_1" :name "add" :arguments "{\"x\":1}"})))
cookie (t/login! app)
conversation [{:id "m1" :role "user" :content "add 1"}
{:id "m2" :role "assistant" :content ""
:toolCalls [{:id "call_0" :type "function" :function {:name "add" :arguments "{\"x\":0}"}}]}
{:id "m3" :role "tool" :toolCallId "call_0" :content "0"}]]
(testing "the tools the page offers go to the LLM, and its calls come back as events"
(let [resp (post-chat app cookie (json {:messages [(first conversation)] :tools [add-tool]}))
evts (events resp)]
(is (= 200 (:status resp)))
(is (= ["RUN_STARTED" "TOOL_CALL_START" "TOOL_CALL_ARGS" "TOOL_CALL_END" "RUN_FINISHED"]
(map :type evts)))
(let [call (first (filter #(= "TOOL_CALL_START" (:type %)) evts))]
(is (= "call_1" (:toolCallId call)))
(is (= "add" (:toolCallName call))))
(is (= "{\"x\":1}" (:delta (first (filter #(= "TOOL_CALL_ARGS" (:type %)) evts)))))))
(testing "the conversation may hold calls and their results, which the LLM gets"
(is (= 200 (:status (post-chat app cookie (json {:messages conversation :tools [add-tool]}))))))
(testing "tools are optional"
(is (= 200 (:status (post-chat app cookie hello)))))))
(deftest page-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(testing "the page the user is on reaches the LLM"
(is (= 200 (:status (post-chat app cookie
(json {:messages [{:id "m1" :role "user" :content "hi"}]
:context [{:description "page" :value "ai-setup"}]}))))))
(testing "it is bounded like any other string, but nothing enforces a slug shape on the wire"
(is (= 200 (:status (post-chat app cookie
(json {:messages [{:id "m1" :role "user" :content "hi"}]
:context [{:description "page" :value "ai-setup"}]}))))))))
(deftest state-test
(let [req (atom nil)
app (app-with (ts/config (ts/text-model-capturing req "ok")))
cookie (t/login! app)
system-text (fn [] (.text ^SystemMessage (first (.messages ^ChatRequest @req))))]
(testing "the page's state reaches the system prompt, so the model doesn't need a tool to read it"
(post-chat app cookie (json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:todos [{:title "milk" :done false}]}}))
(is (str/includes? (system-text) "Current state of the page"))
(is (str/includes? (system-text) "\"title\":\"milk\"")))
(testing "no state, nothing added"
(post-chat app cookie hello)
(is (not (str/includes? (system-text) "Current state of the page"))))
(testing "state is optional, and bounded like a tool's schema"
(is (= 200 (:status (post-chat app cookie (json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:board (vec (repeat 9 nil)) :turn "x"}})))))
(is (= 400 (:status (post-chat app cookie
(json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:huge (apply str (repeat 8000 "x"))}}))))))))
(deftest invalid-tools-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)
user [{:id "m1" :role "user" :content "hi"}]
call {:id "c" :type "function" :function {:name "add" :arguments "{}"}}]
(doseq [[what body] {"a tool without a name" {:messages user :tools [(dissoc add-tool :name)]}
"a tool name that is no function name" {:messages user :tools [(assoc add-tool :name "add it!")]}
"a huge schema" {:messages user :tools [(assoc add-tool :parameters {:type "object" :description (apply str (repeat 6000 "x"))})]}
"too many tools" {:messages user :tools (vec (repeat 33 add-tool))}
"tools that aren't a list" {:messages user :tools add-tool}
"an empty assistant message" {:messages [{:id "m1" :role "assistant" :content ""}]}
"a call without an id" {:messages [{:id "m1" :role "assistant" :content "" :toolCalls [(dissoc call :id)]}]}
"too many calls" {:messages [{:id "m1" :role "assistant" :content "" :toolCalls (vec (repeat 17 call))}]}
"a result without the call's id" {:messages [{:id "m1" :role "tool" :content "3"}]}
"an empty result" {:messages [{:id "m1" :role "tool" :toolCallId "c" :content ""}]}
"a too long result" {:messages [{:id "m1" :role "tool" :toolCallId "c" :content (apply str (repeat 8001 "x"))}]}}]
(is (= 400 (:status (post-chat app cookie (json body)))) what))))
(deftest llm-failure-test
(testing "chat is off without an LLM server"
(let [app (app-with nil)
resp (post-chat app (t/login! app) hello)]
(is (= 503 (:status resp)))
(is (= {:error "chat is not configured"} (:body resp)))))
(testing "an LLM server that can't be reached: a bad gateway before any run starts"
(let [app (app-with (ts/config (ts/error-model "boom")))
resp (post-chat app (t/login! app) hello)]
(is (= 502 (:status resp)))
(is (= "the LLM server can't be reached or refused" (:error (:body resp))))))
(testing "the LLM sends no reply at all: it had already answered with something, even if empty,
so the run had already started"
(let [app (app-with (ts/config (ts/no-reply-model)))
resp (post-chat app (t/login! app) hello)]
(is (= 200 (:status resp)))
(is (= "RUN_ERROR" (:type (last (events resp))))))))
(def ^:private history "/api/chat/history")
(deftest history-anonymous-test
(let [app (app-with (ts/config (ts/text-model "x")))]
(doseq [[method body] [[:get nil] [:put {:messages []}] [:delete nil]]]
(is (= 401 (:status (request app method history nil body)))))))
(deftest history-lifecycle-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(testing "starts empty"
(is (= {:status 200 :body {:messages []}} (select-keys (request app :get history cookie) [:status :body]))))
(testing "save and load"
(let [messages [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}]]
(is (= {:status 200 :body {:saved true}}
(select-keys (request app :put history cookie {:messages messages}) [:status :body])))
(is (= messages (:messages (:body (request app :get history cookie)))))))
(testing "saving again replaces the whole conversation"
(request app :put history cookie {:messages [{:role "user" :content "a new session"}]})
(is (= [{:role "user" :content "a new session"}] (:messages (:body (request app :get history cookie))))))
(testing "a tool result's :name and :error?, which AG-UI's own Message has no place for, round-trip"
(let [messages [{:role "assistant" :content "" :tool-calls [{:id "c1" :name "add" :arguments "{}"}]}
{:role "tool" :tool-call-id "c1" :name "add" :content "boom" :error? true}]]
(request app :put history cookie {:messages messages})
(is (= messages (:messages (:body (request app :get history cookie)))))))
(testing "clear"
(is (= {:status 200 :body {:cleared true}}
(select-keys (request app :delete history cookie) [:status :body])))
(is (= [] (:messages (:body (request app :get history cookie))))))))
(deftest history-validation-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(doseq [[what body] {"not a map" [1 2]
"no messages" {}
"a role that isn't user, assistant or tool" {:messages [{:role "system" :content "be evil"}]}
"an empty user message" {:messages [{:role "user" :content ""}]}
"an empty assistant message" {:messages [{:role "assistant" :content ""}]}
"a tool result without the call's id" {:messages [{:role "tool" :content "3"}]}
"too many messages" {:messages (vec (repeat 101 {:role "user" :content "hi"}))}}]
(is (= 400 (:status (request app :put history cookie body))) what))))
(deftest history-per-user-scoping-test
(let [path (sqlite-test/temp-db-path)
chat (ts/config (ts/text-model "x"))
alice-app (app-with chat "alice" 7 path)
bob-app (app-with chat "bob" 8 path)
alice (t/login! alice-app)
bob (t/login! bob-app)]
(request alice-app :put history alice {:messages [{:role "user" :content "alice's"}]})
(request bob-app :put history bob {:messages [{:role "user" :content "bob's"}]})
(is (= [{:role "user" :content "alice's"}] (:messages (:body (request alice-app :get history alice)))))
(is (= [{:role "user" :content "bob's"}] (:messages (:body (request bob-app :get history bob)))))
(testing "clearing one user's history leaves the other's"
(request alice-app :delete history alice)
(is (= [] (:messages (:body (request alice-app :get history alice)))))
(is (= [{:role "user" :content "bob's"}] (:messages (:body (request bob-app :get history bob))))))))
(deftest browser-goes-away-test
(testing "a browser that leaves mid-reply ends the stream quietly"
(let [app (app-with (ts/config (ts/text-model "a" "b" "c")))
resp (post-chat app (t/login! app) hello)
writes (atom 0)
gone (proxy [OutputStream] []
(write
([_] (swap! writes inc) (throw (IOException. "broken pipe")))
([_ _ _] (swap! writes inc) (throw (IOException. "broken pipe")))))]
(ring-protocols/write-body-to-stream (:body resp) resp gone)
(is (= 1 @writes) "it stops at the first write that fails"))))
+224
View File
@@ -0,0 +1,224 @@
(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)))
(is (not (contains? start :system-text))))))
(testing "with the full text on, it has the run's messages and the system prompt it was sent"
(let [entries (atom [])
messages [{:role "user" :content "old"} {:role "assistant" :content "reply"} {:role "user" :content "new"}]]
(trace/begin! (collecting entries :full-text? true) {:messages messages :system-text "You are..."})
(is (= [{:role "user" :content "new"}] (:input (first @entries))))
(is (= "You are..." (:system-text (first @entries))))))
(testing "every turn has its own req id"
(let [entries (atom [])]
(dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]}))
(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]))))))
+2 -2
View File
@@ -5,7 +5,7 @@
[tbd.core :as core]
[tbd.http :as http]
[tbd.test-util :as test-util]
[tbd.todo.db-test :as db-test])
[tbd.sqlite-test :as sqlite-test])
(:import (java.io ByteArrayInputStream)))
(defn call
@@ -65,7 +65,7 @@
(is (= "application/edn; charset=utf-8" (content-type (call app :get "/api/todos" {}))))))))
(deftest request-format-test
(let [app (t/make-app (t/gitea-stub "alice" 7) :todo {:db-path (db-test/temp-db-path)})
(let [app (t/make-app (t/gitea-stub "alice" 7) :db {:db-path (sqlite-test/temp-db-path)})
cookie (t/login! app)
post (fn [headers body] (call app :post "/api/todos" (assoc headers "cookie" cookie) body))]
(testing "JSON in, EDN out by default"
+18 -13
View File
@@ -6,7 +6,7 @@
[malli.core :as malli]
[tbd.oauth.core :as oauth]
[tbd.oauth.db :as db]
[tbd.oauth.db-test :as db-test]
[tbd.sqlite-test :as sqlite-test]
[tbd.oauth.routes-test :as o]
[tbd.auth.routes-test :as t])
(:import (java.io ByteArrayInputStream)))
@@ -80,9 +80,9 @@
(defn- fixture
"An app on a fresh database, with the tokens of an admin (alice) and a regular user (bob)."
[]
(let [path (db-test/temp-db-path)]
(let [path (sqlite-test/temp-db-path)]
{:path path
:app (t/make-app (t/gitea-stub "alice" 7) :oauth {:db-path path} :todo {:db-path (db-test/temp-db-path)})
:app (t/make-app (t/gitea-stub "alice" 7) :db {:db-path path})
:alice (mint-token! path "alice" 7)
:bob (mint-token! path "bob" 8)}))
@@ -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"
@@ -174,22 +177,22 @@
(is (= 401 (:status resp)))))))
(deftest admin-follows-the-allowlist-test
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
token (mint-token! path "alice" 7)
app-with (fn [admins] (t/make-app (t/gitea-stub "alice") :oauth {:db-path path} :admin-users admins))]
app-with (fn [admins] (t/make-app (t/gitea-stub "alice") :db {:db-path path} :admin-users admins))]
(is (= "alice (Gitea user 7), admin" (text (call-tool (app-with #{"alice"}) token (initialize (app-with #{"alice"}) token) "whoami" {}))))
(testing "it is decided per request, not when the token was issued"
(let [app (app-with #{})]
(is (= "alice (Gitea user 7)" (text (call-tool app token (initialize app token) "whoami" {}))))))))
(deftest unconfigured-test
(let [app (t/make-app (t/gitea-stub "alice") :oauth {:db-path (db-test/temp-db-path)} :gitea-url nil)
(let [app (t/make-app (t/gitea-stub "alice") :db {:db-path (sqlite-test/temp-db-path)} :gitea-url nil)
resp (rpc app "anything" {:jsonrpc "2.0" :id 1 :method "initialize"})]
(is (= 503 (:status resp)) "with no login there is no way to get a token, so /mcp isn't open instead")))
(deftest end-to-end-test
(testing "a client that does the whole OAuth dance ends up as the user who approved it"
(let [app (o/app-for (db-test/temp-db-path) "carol" 9)
(let [app (o/app-for (sqlite-test/temp-db-path) "carol" 9)
{:keys [client-id tokens]} (o/get-tokens! app)
whoami (fn [access-token] (text (call-tool app access-token (initialize app access-token) "whoami" {})))]
(is (= "carol (Gitea user 9)" (whoami (:access_token tokens))))
@@ -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}))))))
+32 -11
View File
@@ -1,12 +1,9 @@
(ns tbd.oauth.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[tbd.oauth.db :as db])
(:import (java.nio.file Files)
(java.nio.file.attribute FileAttribute)))
(defn temp-db-path []
(str (Files/createTempDirectory "tbd-oauth" (make-array FileAttribute 0)) "/data/oauth.db"))
[next.jdbc :as jdbc]
[tbd.oauth.db :as db]
[tbd.sqlite-test :refer [temp-db-path]]))
(defn client [id created-at]
{:id id :name "Test client" :redirect-uris ["https://c.example.com/cb" "http://localhost/cb"] :created-at created-at})
@@ -17,11 +14,6 @@
:refresh-hash (str "refresh-" n) :refresh-expires-at 9000
:created-at 1000})
(deftest env-config-test
(is (= {:db-path "data/oauth.db"} (db/env-config {})))
(is (= {:db-path "data/oauth.db"} (db/env-config {"OAUTH_DB_PATH" " "})))
(is (= {:db-path "/var/oauth.db"} (db/env-config {"OAUTH_DB_PATH" " /var/oauth.db "}))))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
@@ -55,6 +47,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 +81,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})))))))
+12 -12
View File
@@ -6,7 +6,7 @@
[tbd.auth.routes-test :as t]
[tbd.oauth.core :as oauth]
[tbd.oauth.db :as db]
[tbd.oauth.db-test :as db-test]
[tbd.sqlite-test :as sqlite-test]
[tbd.test-util :as test-util])
(:import (java.io ByteArrayInputStream)
(java.net URLDecoder)))
@@ -23,7 +23,7 @@
(defn app-for
"An app whose OAuth database is `path`; the Gitea user is alice (id 7), an admin, unless told otherwise."
([path] (app-for path "alice" 7))
([path login id] (t/make-app (t/gitea-stub login id) :oauth {:db-path path})))
([path login id] (t/make-app (t/gitea-stub login id) :db {:db-path path})))
(defn call
"Runs a request through `app`. `:form` (a map) is sent as a urlencoded body, `:body` (a string) as JSON."
@@ -94,7 +94,7 @@
{:client-id client-id :cookie cookie :tokens (:body (token! app client-id code))}))
(deftest discovery-test
(let [app (app-for (db-test/temp-db-path))]
(let [app (app-for (sqlite-test/temp-db-path))]
(testing "protected resource metadata, at the root and at the resource's own path"
(doseq [uri ["/.well-known/oauth-protected-resource" "/.well-known/oauth-protected-resource/mcp"]]
(let [resp (call app :get uri)]
@@ -112,8 +112,8 @@
[:headers "Content-Type"]))))))
(deftest unconfigured-test
(let [path (db-test/temp-db-path)
app (t/make-app (t/gitea-stub "alice") :oauth {:db-path path} :gitea-url nil)]
(let [path (sqlite-test/temp-db-path)
app (t/make-app (t/gitea-stub "alice") :db {:db-path path} :gitea-url nil)]
(doseq [[method uri] [[:get "/.well-known/oauth-protected-resource"]
[:get "/.well-known/oauth-authorization-server"]
[:post "/oauth/register"]
@@ -123,7 +123,7 @@
(is (= 503 (:status (call app method uri))) (str method " " uri)))))
(deftest register-test
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
app (app-for path)]
(testing "a client is registered as a public client"
(let [resp (call app :post "/oauth/register"
@@ -168,7 +168,7 @@
(is (= error (get-in resp [:body :error])) why))))))
(deftest authorize-request-errors-test
(let [app (app-for (db-test/temp-db-path))
(let [app (app-for (sqlite-test/temp-db-path))
client-id (register! app)
cookie (t/login! app)
open (fn [params] (call app :get "/oauth/authorize" :cookie cookie :query (auth/form-encode params)))]
@@ -206,7 +206,7 @@
:query (str "client_id=" client-id "&client_id=" client-id))))))))
(deftest login-then-consent-test
(let [app (app-for (db-test/temp-db-path))
(let [app (app-for (sqlite-test/temp-db-path))
client-id (register! app)
query (auth/form-encode (authorize-params client-id))]
(testing "a logged-out user is sent to log in first, and back afterwards"
@@ -224,7 +224,7 @@
(is (str/includes? (:body page) "Test client")))))))))
(deftest consent-page-test
(let [app (app-for (db-test/temp-db-path))
(let [app (app-for (sqlite-test/temp-db-path))
client-id (register! app {:client_name "<script>alert(1)</script>"})
{:keys [page csrf]} (consent! app (t/login! app) (authorize-params client-id))]
(is (= 200 (:status page)))
@@ -243,7 +243,7 @@
(is (= "no-store" (get-in page [:headers "Cache-Control"]))))))
(deftest consent-decision-test
(let [app (app-for (db-test/temp-db-path))
(let [app (app-for (sqlite-test/temp-db-path))
client-id (register! app)
params (authorize-params client-id)
cookie (t/login! app)]
@@ -282,7 +282,7 @@
(is (nil? (get-in resp [:headers "Location"])))))))
(deftest code-exchange-test
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
app (app-for path)
client-id (register! app)
other-client-id (register! app)
@@ -340,7 +340,7 @@
"the token endpoint takes forms, as RFC 6749 says"))))
(deftest refresh-test
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
app (app-for path)
{:keys [client-id tokens]} (get-tokens! app)
refresh! (fn [refresh-token & {:as overrides}]
+44
View File
@@ -0,0 +1,44 @@
(ns tbd.sqlite-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[next.jdbc :as jdbc]
[tbd.oauth.db :as oauth-db]
[tbd.sqlite :as sqlite]
[tbd.todo.db :as todo-db])
(:import (java.nio.file Files)
(java.nio.file.attribute FileAttribute)))
(defn temp-db-path
"A path for a database file inside a fresh temp directory (which `open` has to create a
subdirectory of, as with the default data/tbd.db)."
[]
(str (Files/createTempDirectory "tbd" (make-array FileAttribute 0)) "/data/tbd.db"))
(deftest env-config-test
(is (= {:db-path "data/tbd.db"} (sqlite/env-config {})))
(is (= {:db-path "data/tbd.db"} (sqlite/env-config {"DB_PATH" " "})))
(is (= {:db-path "/var/tbd.db"} (sqlite/env-config {"DB_PATH" " /var/tbd.db "}))))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
(sqlite/open path todo-db/migrate!)
(is (.exists (io/file path)))))
(testing "no path is an error, not a database in the working directory"
(is (thrown? clojure.lang.ExceptionInfo (sqlite/open nil)))
(is (thrown? clojure.lang.ExceptionInfo (sqlite/open " "))))
(testing "every migration runs on the datasource, and again (harmlessly) on reopening"
(let [path (temp-db-path)
tables #(set (map :name (jdbc/execute! % ["SELECT name FROM sqlite_master WHERE type = 'table'"]
{:builder-fn next.jdbc.result-set/as-unqualified-maps})))]
(is (every? (tables (sqlite/open path todo-db/migrate! oauth-db/migrate!))
["todos" "clients" "codes" "grants"]))
(is (every? (tables (sqlite/open path todo-db/migrate! oauth-db/migrate!))
["todos" "clients" "codes" "grants"]))))
(testing "the groups keep their data apart in the one file"
(let [path (temp-db-path)
ds (sqlite/open path todo-db/migrate! oauth-db/migrate!)]
(todo-db/insert! ds {:owner-id 7 :title "buy milk" :done false :created-at 1 :updated-at 1})
(oauth-db/insert-client! ds {:id "c1" :name "Test client" :redirect-uris ["http://localhost/cb"] :created-at 1})
(is (= ["buy milk"] (map :title (todo-db/list-todos ds 7))))
(is (= "c1" (:id (oauth-db/find-client ds "c1")))))))
+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"
+44 -17
View File
@@ -1,24 +1,13 @@
(ns tbd.todo.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[tbd.todo.db :as db])
(:import (java.nio.file Files)
(java.nio.file.attribute FileAttribute)))
(defn temp-db-path
"A path for a database file inside a fresh temp directory (which `open` has to create a
subdirectory of, as with the default data/todo.db)."
[]
(str (Files/createTempDirectory "tbd-todo" (make-array FileAttribute 0)) "/data/todo.db"))
[next.jdbc :as jdbc]
[tbd.sqlite-test :refer [temp-db-path]]
[tbd.todo.db :as db]))
(defn todo [owner-id title]
{:owner-id owner-id :title title :done false :created-at 1000 :updated-at 1000})
(deftest env-config-test
(is (= {:db-path "data/todo.db"} (db/env-config {})))
(is (= {:db-path "data/todo.db"} (db/env-config {"TODO_DB_PATH" " "})))
(is (= {:db-path "/var/todo.db"} (db/env-config {"TODO_DB_PATH" " /var/todo.db "}))))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
@@ -38,6 +27,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 +37,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 +58,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)))))))))
+12 -11
View File
@@ -3,7 +3,7 @@
[clojure.test :refer [deftest is testing]]
[tbd.auth.routes-test :as t]
[tbd.test-util :as test-util]
[tbd.todo.db-test :as db-test])
[tbd.sqlite-test :as sqlite-test])
(:import (java.io ByteArrayInputStream)))
(defn request
@@ -15,12 +15,12 @@
(test-util/decode-body resp)))
(defn app-for [db-path login id]
(t/make-app (t/gitea-stub login id) :todo {:db-path db-path}))
(t/make-app (t/gitea-stub login id) :db {:db-path db-path}))
(def ^:private todos "/api/todos")
(deftest anonymous-test
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
app (app-for path "alice" 7)]
(doseq [[method uri body] [[:get todos nil]
[:post todos "{\"title\":\"x\"}"]
@@ -34,7 +34,7 @@
(is (not (.exists (io/file path))) "the database isn't even opened")))
(deftest lifecycle-test
(let [app (app-for (db-test/temp-db-path) "alice" 7)
(let [app (app-for (sqlite-test/temp-db-path) "alice" 7)
cookie (t/login! app)]
(testing "starts empty"
(let [resp (request app :get todos cookie)]
@@ -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"
@@ -65,7 +65,7 @@
(is (= ["walk dog"] (map :title (:todos (:body (request app :get todos cookie)))))))))))
(deftest validation-test
(let [app (app-for (db-test/temp-db-path) "alice" 7)
(let [app (app-for (sqlite-test/temp-db-path) "alice" 7)
cookie (t/login! app)
created (:body (request app :post todos cookie "{\"title\":\"keep\"}"))
one (str todos "/" (:id created))]
@@ -79,13 +79,14 @@
(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
(let [path (db-test/temp-db-path)
(let [path (sqlite-test/temp-db-path)
alice-app (app-for path "alice" 7)
bob-app (app-for path "bob" 8)
alice (t/login! alice-app)
@@ -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))
+4 -4
View File
@@ -2,7 +2,7 @@
(:require [clojure.test :refer [deftest is testing]]
[tbd.todo.core :as todo]
[tbd.todo.db :as db]
[tbd.todo.db-test :as db-test]
[tbd.sqlite-test :as sqlite-test]
[tbd.todo.service :as service]))
;; The rules every front end (HTTP routes, MCP tools) gets: ownership, not-found and validation.
@@ -11,7 +11,7 @@
(def alice {:id 7 :login "alice"})
(def bob {:id 8 :login "bob"})
(defn- fresh-ds [] (let [path (db-test/temp-db-path)] (delay (db/open path))))
(defn- fresh-ds [] (let [path (sqlite-test/temp-db-path)] (delay (db/open path))))
(def ^:private not-found {:error "todo not found" :kind :not-found})
@@ -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"
@@ -68,7 +68,7 @@
(deftest database-is-opened-on-use-test
(testing "nothing opens the database until a service fn needs it"
(let [opened (atom 0)
ds (delay (swap! opened inc) (db/open (db-test/temp-db-path)))]
ds (delay (swap! opened inc) (db/open (sqlite-test/temp-db-path)))]
(is (zero? @opened))
(service/list-todos ds alice)
(service/list-todos ds alice)
+7
View File
@@ -0,0 +1,7 @@
{
"temp-directory": "target/c8",
"reports-dir": "../target/coverage/ui",
"reporter": ["text", "html", "lcovonly"],
"include": [".shadow-cljs/builds/test/dev/out/cljs-runtime/tbd.ui.*.js"],
"exclude": ["**/node_modules/**", "**/*_test.js", "**/tbd.ui.test_util.js"]
}
+1165
View File
File diff suppressed because it is too large Load Diff
+5 -1
View File
@@ -5,7 +5,9 @@
"description": "ClojureScript (re-frame) front end for the tbd server",
"scripts": {
"watch": "shadow-cljs watch app",
"release": "shadow-cljs release app"
"release": "shadow-cljs release app",
"test": "shadow-cljs compile test && node -r ./test/dom-setup.cjs target/ui-test/test.js",
"coverage": "shadow-cljs compile test && c8 --reporter=none node -r ./test/dom-setup.cjs target/ui-test/test.js && cp -r src/tbd .shadow-cljs/builds/test/dev/out/cljs-runtime/ && c8 report"
},
"dependencies": {
"@jason.today/webmcp": "0.1.13",
@@ -13,6 +15,8 @@
"react-dom": "^19.3.0"
},
"devDependencies": {
"c8": "^12.0.0",
"jsdom": "^30.1.0",
"shadow-cljs": "^3.5.3"
}
}
+7 -5
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"]
@@ -13,8 +14,9 @@
:modules {:main {:init-fn tbd.ui.core/init}}
:devtools {:after-load tbd.ui.core/reload}}
;; script/ui-test: the tests run under Node, against fakes of fetch and navigator.modelContext.
;; script/ui-test (npm test): the tests run under Node, in a jsdom window (test/dom-setup.cjs,
;; which npm test preloads), against a fake server (fetch). Not :autorun: the preload has to
;; come first, so npm test starts node itself.
:test {:target :node-test
:output-to "target/ui-test/test.js"
:ns-regexp "-test$"
:autorun true}}}
:ns-regexp "-test$"}}}
+12 -2
View File
@@ -2,6 +2,7 @@
(:require [re-frame.core :as rf]
[reagent.dom.client :as rdc]
[tbd.ui.events :as events]
[tbd.ui.model-context :as model-context]
[tbd.ui.views :as views]
[tbd.ui.webmcp :as webmcp]))
@@ -10,15 +11,24 @@
(defn- render []
(rdc/render @root [views/app]))
(defn- offer-tools!
"The page's tools and state go to the chatbot in the page; the tools (all of them, including the
read-only ones the chatbot itself isn't offered, see tbd.ui.model-context/definitions) also go to
an agent outside it, through WebMCP."
[]
(model-context/register! webmcp/tools)
(model-context/register-state! webmcp/state-providers)
(webmcp/register!))
(defn reload
"Called by shadow-cljs after each hot reload."
[]
(rf/clear-subscription-cache!)
(webmcp/register!)
(offer-tools!)
(render))
(defn init []
(rf/dispatch-sync [::events/initialize])
(reset! root (rdc/create-root (js/document.getElementById "app")))
(webmcp/register!)
(offer-tools!)
(render))
+34 -15
View File
@@ -2,26 +2,45 @@
(:require [tbd.ui.tictactoe :as tictactoe]))
(def default-db
{:calc {:x "" :y ""
;; {:status :idle}
;; {:status :loading}
;; {:status :ok :x "2" :y "3" :sum 5}
;; {:status :error :message "..."}
{;; Which page is showing (tbd.ui.pages); follows the URL's fragment.
:page :tic-tac-toe
:calc {:x "" :y ""
;; :result is {:status :idle|:loading}, {:status :ok :x :y :sum}, or
;; {:status :error :message}.
:result {:status :idle}}
;; {:status :unknown} (asking /auth/me)
;; {:status :anonymous} (not logged in)
;; {:status :logged-in :login "alice"}
;; {:status :error :message "..."}
;; :user is {:status :unknown}, {:status :anonymous}, {:status :logged-in :login "alice"}, or
;; {:status :error :message}.
:user {:status :unknown}
;; :status is the list load: :idle, :loading, :ok or :error. :error is the message of the
;; last failed request (a load or a change); it is cleared when the next request starts.
:todos {:status :idle
:todos {;; :status is :idle, :loading, :ok or :error; :error is the last failed request's
;; message, cleared when the next request starts.
:status :idle
:items []
:new-title ""
:error nil}
;; The "Add this MCP server to Claude Code" section: :copied? is true right after the
;; command was copied to the clipboard.
;; The "Add this MCP server to Claude Code" page. :copied? is true right after the command was
;; copied to the clipboard.
:mcp {:copied? false}
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is.
;; The chat widget (the green square). A message is {:role "user"|"assistant"|"tool" :content}
;; with :tool-calls [{:id :name :arguments}] and :thinking on an assistant message that used
;; tools or reasoned, and :tool-call-id/:name on a tool message. :size is the panel's dragged
;; :width/:height. :tools-expanded?/:reasoning-expanded? control whether tool use/reasoning show
;; in full or collapsed. :pending-calls/:tool-calls-used/:tools-used-this-turn/:thinking-at
;; track a reply that is still coming or being answered (see tbd.ui.events).
:chat {:open? false
:size {:width 320 :height 256}
:tools-expanded? false
:reasoning-expanded? false
:input ""
:messages []
:status :idle
:error nil
:pending-calls nil
;; Tool calls still streaming in (AG-UI's TOOL_CALL_START/ARGS/END), keyed by
;; toolCallId, until complete and moved into :pending-calls.
:tool-call-buffer {}
:thinking-at nil
:tool-calls-used 0
:tools-used-this-turn #{}}
;; Tic-tac-toe, client side only.
:ttt {:board tictactoe/new-board
:turn :x}})
+642 -31
View File
@@ -3,30 +3,187 @@
[clojure.string :as str]
[re-frame.core :as rf]
[tbd.ui.db :as db]
[tbd.ui.model-context :as model-context]
[tbd.ui.pages :as pages]
[tbd.ui.sse :as sse]
[tbd.ui.tictactoe :as tictactoe]))
;; Effect: request `uri` (GET unless `method` is given), then dispatch
;; `(conj on-response {:ok? bool :status int-or-nil :body string})`. A `body` is sent as EDN.
;; Network failures come back as `{:ok? false :status nil :body <message>}`.
(defn- fetch-request
"GETs (or `method`s) `uri`. `body`, if given, is sent as EDN. `signal` (an AbortSignal) aborts it."
[{:keys [uri method body signal]}]
(js/fetch uri (cond-> (clj->js (cond-> {:method (or method "GET")}
body (assoc :headers {"Content-Type" "application/edn"}
:body (pr-str body))))
signal (doto (aset "signal" signal)))))
(defn- response-map [resp text]
{:ok? (.-ok resp) :status (.-status resp) :body text})
(defn- do-fetch!
"Fetches `request` (see fetch-request), dispatching `(conj on-response {:ok? :status :body})`.
A network failure dispatches `{:ok? false :status nil :body message}`."
[{:keys [on-response] :as request}]
(-> (fetch-request request)
(.then (fn [resp]
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)})))))
(rf/reg-fx ::fetch do-fetch!)
;; Same as ::fetch, with its own id so chat-history saves don't collide with the chat stream's
;; requests in tests.
(rf/reg-fx ::persist-chat do-fetch!)
(def ^:private connection-lost {:type "RUN_ERROR" :message "the connection was lost"})
(def ^:private terminal-event-types
"The AG-UI event types (see tbd.chat.routes) that end a run."
#{"RUN_FINISHED" "RUN_ERROR"})
(defn- read-events!
"Dispatches `(conj on-event event)` for each AG-UI event decoded from `reader`, as it arrives. A
stream that ends without a RUN_FINISHED/RUN_ERROR event dispatches a RUN_ERROR of its own — unless
`signal` was aborted, in which case nothing more is dispatched."
[reader on-event ^js signal]
(let [decoder (js/TextDecoder. "utf-8")
ended? (atom false)
aborted? #(.-aborted signal)
lost! #(when-not (or @ended? (aborted?))
(reset! ended? true)
(rf/dispatch (conj on-event connection-lost)))
step (fn step [pending]
(-> (.read reader)
(.then (fn [^js chunk]
(cond
(aborted?) (some-> (.-cancel reader) (.call reader) (.catch (fn [_] nil)))
(.-done chunk) (lost!)
:else
(let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk)
#js {:stream true})))]
(doseq [event events]
(when (contains? terminal-event-types (:type event)) (reset! ended? true))
(rf/dispatch (conj on-event event)))
(step pending)))))
(.catch (fn [_] (lost!)))))]
(step "")))
;; The in-flight stream's AbortController, for ::abort-stream. Only one stream runs at a time.
(defonce ^:private stream-controller (atom nil))
;; Like ::fetch, for a streamed response: dispatches `(conj on-event event)` for each event as it
;; arrives (see read-events!), or `(conj on-response {:ok? false ...})` if the request itself fails.
;; Nothing more is dispatched once ::abort-stream has run.
(rf/reg-fx
::fetch
(fn [{:keys [uri method body on-response]}]
(-> (js/fetch uri (clj->js (cond-> {:method (or method "GET")}
body (assoc :headers {"Content-Type" "application/edn"}
:body (pr-str body)))))
(.then (fn [resp]
(.then (.text resp)
#(rf/dispatch (conj on-response {:ok? (.-ok resp)
:status (.-status resp)
:body %})))))
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
::fetch-stream
(fn [{:keys [on-event on-response] :as request}]
(let [controller (js/AbortController.)
signal (.-signal controller)
respond! #(when-not (.-aborted signal) (rf/dispatch (conj on-response %)))]
(reset! stream-controller controller)
(-> (fetch-request (assoc request :signal signal))
(.then (fn [resp]
(if (.-ok resp)
(read-events! (.getReader (.-body resp)) on-event signal)
(.then (.text resp) #(respond! (response-map resp %))))))
(.catch #(respond! {:ok? false :status nil :body (.-message %)}))))))
;; Aborts the in-flight stream, if any. Closing the connection is what tells the server to stop
;; the LLM (see tbd.chat.routes/event-stream).
(rf/reg-fx
::abort-stream
(fn [_]
(when-let [controller @stream-controller]
(reset! stream-controller nil)
(.abort controller))))
;; The URL's fragment, which says which page to start on.
(rf/reg-cofx
::hash
(fn [cofx _]
(assoc cofx :hash js/location.hash)))
(rf/reg-cofx
::now
(fn [cofx _]
(assoc cofx :now (js/Date.now))))
(def ^:private chat-ui-storage-key "tbd.chat-ui")
;; The chat widget's saved :open?/:size, or nil if there is none (or it's unreadable).
(rf/reg-cofx
::chat-ui-storage
(fn [cofx _]
(assoc cofx ::chat-ui
(try
(some-> (.getItem js/localStorage chat-ui-storage-key)
reader/read-string
(select-keys [:open? :size]))
(catch :default _ nil)))))
(rf/reg-fx
::persist-chat-ui
(fn [chat-ui]
(.setItem js/localStorage chat-ui-storage-key (pr-str chat-ui))))
(def ^:private ttt-storage-key "tbd.ttt")
;; The tic-tac-toe :board/:turn as last saved, or nil.
(rf/reg-cofx
::ttt-storage
(fn [cofx _]
(assoc cofx ::ttt
(try
(some-> (.getItem js/localStorage ttt-storage-key)
reader/read-string
(select-keys [:board :turn]))
(catch :default _ nil)))))
(rf/reg-fx
::persist-ttt
(fn [ttt]
(.setItem js/localStorage ttt-storage-key (pr-str ttt))))
;; Shows the page named by the URL whenever it changes (a link, or Back/Forward). Installs at
;; most one listener, however often this runs.
(defonce ^:private hash-listener (atom nil))
(rf/reg-fx
::listen-for-hash
(fn [_]
(when-let [old @hash-listener]
(.removeEventListener js/window "hashchange" old))
(reset! hash-listener #(rf/dispatch [::hash-changed js/location.hash]))
(.addEventListener js/window "hashchange" @hash-listener)))
(rf/reg-fx
::set-hash
(fn [hash]
(set! js/location.hash hash)))
(rf/reg-event-fx
::initialize
(fn [_ _]
{:db db/default-db
[(rf/inject-cofx ::hash) (rf/inject-cofx ::chat-ui-storage) (rf/inject-cofx ::ttt-storage)]
(fn [{:keys [hash ::chat-ui ::ttt]} _]
{:db (cond-> (assoc db/default-db :page (pages/hash->page hash))
chat-ui (update :chat merge chat-ui)
ttt (update :ttt merge ttt))
::listen-for-hash true
:dispatch [::load-user]}))
;; --- Pages ---
(rf/reg-event-db
::hash-changed
(fn [db [_ hash]]
(assoc db :page (pages/hash->page hash))))
;; Navigates without a link: the page changes right away, and the URL follows.
(rf/reg-event-fx
::navigate
(fn [{:keys [db]} [_ page]]
{:db (assoc db :page page)
::set-hash (pages/page->hash page)}))
(rf/reg-event-db
::set-operand
(fn [db [_ k value]]
@@ -72,7 +229,7 @@
(cond
ok? {:db (assoc db :user {:status :logged-in
:login (:login (reader/read-string (:body resp)))})
:dispatch [::load-todos]}
:dispatch-n [[::load-chat-history] [::load-todos]]}
(= 401 status) {:db (assoc db :user {:status :anonymous})}
:else {:db (assoc db :user {:status :error :message (error-message resp)})})))
@@ -81,11 +238,19 @@
(fn [_ _]
{::fetch {:uri "/auth/logout" :method "POST" :on-response [::logout-response]}}))
(defn- reset-chat
"An empty conversation, keeping the panel's :open?/:size/:tools-expanded?/:reasoning-expanded?."
[db]
(assoc db :chat (merge (:chat db/default-db)
(select-keys (:chat db) [:open? :size :tools-expanded? :reasoning-expanded?]))))
(rf/reg-event-db
::logout-response
(fn [db [_ {:keys [ok?] :as resp}]]
(if ok?
(assoc db :user {:status :anonymous} :todos (:todos db/default-db))
(-> db
(assoc :user {:status :anonymous} :todos (:todos db/default-db))
reset-chat)
(assoc-in db [:todos :error] (error-message resp)))))
;; --- Todos ---
@@ -106,8 +271,8 @@
(update db :todos assoc :status :ok :items (:todos (reader/read-string body)))
(update db :todos assoc :status :error :error (error-message resp)))))
;; A failed change keeps the list as it is and shows the message. A 401 means the session
;; expired, so fall back to the logged-out view (which hides the todos).
;; A 401 means the session expired: fall back to the logged-out view. Otherwise the list stays,
;; with the error shown.
(rf/reg-event-db
::todo-failed
(fn [db [_ {:keys [status] :as resp}]]
@@ -169,10 +334,453 @@
{:db (update-in db [:todos :items] (fn [items] (filterv #(not= id (:id %)) items)))}
{:dispatch [::todo-failed resp]})))
;; --- MCP setup section ---
;; --- Chat ---
;; Effect: put `text` on the clipboard. The Clipboard API only exists on secure origins (https
;; or localhost), so the view doesn't offer the button without it; failures are ignored.
;; The chat loops when the LLM calls tools of the page (tbd.ui.model-context): the page runs them
;; and resends the conversation, until the LLM answers without asking for more.
(def ^:private max-sent-messages
"How much of the conversation goes to the server per request (bounded by
tbd.chat.schema/max-messages), the most recent part."
40)
(def ^:private max-tool-calls-per-turn
"Max tool calls the LLM may make answering one message, before the turn is stopped as a runaway
loop. (A turn is at most 1 + this many assistant messages and this many results, so it always
stays within max-sent-messages.)"
12)
(def ^:private max-tool-result-length
"The longest tool result sent to the LLM (tbd.chat.schema/max-message-length)."
8000)
(def ^:private truncated " … (truncated)")
(defn- display-text
"`text` for the chat log, never empty. Kept in full here; only what leaves the tab is cut down,
by fit-result."
[text]
(if (str/blank? text) "(no output)" text))
(defn- fit-result
"`text`, cut to max-tool-result-length, for a tool result about to leave the tab."
[text]
(if (> (count text) max-tool-result-length)
(str (subs text 0 (- max-tool-result-length (count truncated))) truncated)
text))
(defonce ^:private id-counter (atom 0))
(defn- next-id
"A fresh id for an AG-UI message, unique within this page's session."
[]
(str "m" (swap! id-counter inc)))
(defn- wire-message
"A conversation message as AG-UI's Message (tbd.chat.schema/Message). A tool result is fit to
the server's limit here; the browser's own copy stays whole."
[{:keys [role content tool-calls tool-call-id]}]
(cond-> {:id (next-id) :role role}
(= "tool" role) (assoc :toolCallId tool-call-id :content (fit-result content))
(not= "tool" role) (assoc :content content)
(seq tool-calls) (assoc :toolCalls (mapv (fn [{:keys [id name arguments]}]
{:id id :type "function"
:function {:name name :arguments arguments}})
tool-calls))))
(defn- windowed
"The most recent `n` of `messages`, dropping a leading tool result whose call fell out of the
window."
[n messages]
(drop-while #(= "tool" (:role %)) (take-last n messages)))
(defn- recent [messages]
(windowed max-sent-messages messages))
(def ^:private max-stored-messages
"How much of the conversation is saved for \"restore my last session\" (bounded by
tbd.chat.schema/max-history-messages): more than max-sent-messages, since this is scrollback."
100)
(def ^:private max-stored-content-length
"The longest tool result or reasoning kept in a saved conversation
(tbd.chat.schema/max-history-content-length): the full log, for \"Expand\"/\"Show reasoning\"
after a reload, not cut to what the LLM sees."
100000)
(def ^:private max-stored-length
"Total length of a saved conversation, printed (tbd.chat.schema/max-history-length)."
1000000)
(declare only-reasoning?)
(defn- fit-stored [text]
(if (> (count text) max-stored-content-length)
(str (subs text 0 (- max-stored-content-length (count truncated))) truncated)
text))
(defn- storable
"The most recent `max-stored-messages` of `messages`, as /api/chat/history's PUT wants them.
Drops replies that came to nothing but reasoning, and fits tool results/reasoning to
max-stored-content-length. If the total is still over max-stored-length, drops whole oldest
turns (never a result without its call, or a reply without its question)."
[messages]
(let [fitted (into []
(comp (remove only-reasoning?)
(map (fn [message]
(cond-> message
(= "tool" (:role message)) (update :content fit-stored)
(:thinking message) (update :thinking fit-stored)))))
(windowed max-stored-messages messages))
sizes (mapv #(inc (count (pr-str %))) fitted)]
(loop [messages fitted
size (reduce + 2 sizes)
sizes sizes]
(if (and (> size max-stored-length) (seq messages))
(let [n (inc (count (take-while #(not= "user" (:role %)) (rest messages))))]
(recur (subvec messages n) (- size (reduce + (take n sizes))) (subvec sizes n)))
messages))))
;; Best-effort save of the conversation for /api/chat/history to hand back on next login. Never
;; blocks anything: a failure is retried at the next natural save point.
(defn- save-chat-fx [db]
{:uri "/api/chat/history" :method "PUT"
:body {:messages (storable (get-in db [:chat :messages]))}
:on-response [::save-chat-history-response]})
(rf/reg-event-db
::save-chat-history-response
(fn [db [_ {:keys [status]}]]
(if (= 401 status)
(-> db (assoc :user {:status :anonymous}) reset-chat)
db)))
(defn- wire-tool
"A tool as AG-UI's Tool has it (tbd.chat.schema/Tool): `parameters`, not MCP's `inputSchema`."
[{:keys [name description inputSchema]}]
(cond-> {:name name :parameters inputSchema}
description (assoc :description description)))
;; An AG-UI RunAgentInput: the page's name (as `context`, so the LLM knows where the user is), the
;; tools that page offers, and its current state (model-context/current-state), so the LLM never
;; has to spend a call finding out. Read from the db each time, so a conversation that moves
;; between pages always reflects where it is now.
(defn- chat-request [db messages]
(let [page (:page db)
once (model-context/once-per-turn-names page)
used (get-in db [:chat :tools-used-this-turn])
tools (remove (comp #(and (once %) (used %)) :name) (model-context/definitions page))
state (model-context/current-state page)
messages (remove only-reasoning? messages)]
{:uri "/api/chat" :method "POST"
:body (cond-> {:threadId (next-id) :runId (next-id)
:messages (mapv wire-message (recent messages))
:context [{:description "page" :value (name page)}]}
(seq tools) (assoc :tools (mapv wire-tool tools))
(seq state) (assoc :state state))
:on-event [::chat-event]
:on-response [::chat-response]}))
;; Restores the last session, right after login. Merged in only if nothing has been said in this
;; page load yet, so a slow response can't stomp on a conversation already started.
(rf/reg-event-fx
::load-chat-history
(fn [_ _]
{::fetch {:uri "/api/chat/history" :on-response [::chat-history-response]}}))
(rf/reg-event-db
::chat-history-response
(fn [db [_ {:keys [ok? body]}]]
(if (and ok? (empty? (get-in db [:chat :messages])))
(assoc-in db [:chat :messages] (:messages (reader/read-string body)))
db)))
(rf/reg-event-fx
::chat-toggle
(fn [{:keys [db]} _]
(let [db (update-in db [:chat :open?] not)]
{:db db
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
(rf/reg-event-fx
::chat-resize
(fn [{:keys [db]} [_ width height]]
(let [db (assoc-in db [:chat :size] {:width width :height height})]
{:db db
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
(rf/reg-event-db
::chat-toggle-tools
(fn [db _]
(update-in db [:chat :tools-expanded?] not)))
(rf/reg-event-db
::chat-toggle-reasoning
(fn [db _]
(update-in db [:chat :reasoning-expanded?] not)))
(rf/reg-event-db
::chat-set-input
(fn [db [_ input]]
(assoc-in db [:chat :input] input)))
(rf/reg-event-fx
::chat-send
(fn [{:keys [db]} _]
(let [{:keys [input messages status]} (:chat db)
content (str/trim input)]
(when (and (not= :loading status) (seq content))
(let [messages (conj messages {:role "user" :content content})
db (update db :chat assoc :messages messages :input "" :status :loading :error nil
:tool-calls-used 0 :tools-used-this-turn #{})]
{:db db
::fetch-stream (chat-request db messages)
::persist-chat (save-chat-fx db)})))))
(defn- only-reasoning?
"Whether `message` is a reply that has come to nothing but reasoning: no content, no tool calls
(the server refuses a message that says and asks for nothing)."
[{:keys [role content tool-calls]}]
(and (= "assistant" role) (str/blank? content) (empty? tool-calls)))
(defn- chat-failed
"The conversation after a send failed with `message`. If nothing of the reply had come, the
unanswered user message goes back into the input (so retrying is just pressing Send); otherwise
whatever came stays, and the next message follows it."
[db message]
(let [messages (get-in db [:chat :messages])
messages (cond-> messages (only-reasoning? (peek messages)) pop)
unanswered? (= "user" (:role (peek messages)))]
(update db :chat merge
{:status :idle :error message :pending-calls nil :messages messages}
(when unanswered?
{:messages (pop messages) :input (:content (peek messages))}))))
;; The server answered without a stream: the request failed. A 401 means the session expired.
;; A response nobody is waiting for (the conversation was reset since) is dropped.
(rf/reg-event-fx
::chat-response
(fn [{:keys [db]} [_ {:keys [status] :as resp}]]
(cond
(not= :loading (get-in db [:chat :status])) {:db db}
(= 401 status) {:db (-> db (assoc :user {:status :anonymous}) reset-chat)}
:else (let [db (chat-failed db (error-message resp))]
{:db db ::persist-chat (save-chat-fx db)}))))
(defn- append-to-reply
"The conversation with `text` added to the assistant message being written (starting one if
needed). Leading whitespace is dropped until the message has content (a reasoning model often
opens with a stray blank line), then preserved."
[db text]
(update-in db [:chat :messages]
(fn [messages]
(if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) update :content
(fn [content]
(str content (if (str/blank? content) (str/triml text) text))))
(conj messages {:role "assistant" :content (str/triml text)})))))
(defn- append-reasoning
"Like append-to-reply, but onto :thinking, kept apart from :content so \"Show reasoning\" can
reveal it for the right reply."
[db text]
(update-in db [:chat :messages]
(fn [messages]
(if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) update :thinking str text)
(conj messages {:role "assistant" :content "" :thinking text})))))
(defn- with-tool-calls
"The conversation with `calls` attached to the reply (on its text, or a fresh message if it said
nothing)."
[messages calls]
(if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) assoc :tool-calls calls)
(conj messages {:role "assistant" :content "" :tool-calls calls})))
(defn- tool-message [{:keys [id name content error?]}]
{:role "tool" :tool-call-id id :name name :content content :error? (boolean error?)})
(defn- blocked-calls
"`calls`, each marked `:blocked?` when it names a once-per-turn tool (model-context/once-per-turn-names)
already used this turn, or by an earlier call in this same batch."
[once used calls]
(first (reduce (fn [[marked seen] {:keys [name] :as call}]
(let [counts? (once name)]
[(conj marked (cond-> call (and counts? (or (used name) (seen name))) (assoc :blocked? true)))
(cond-> seen counts? (conj name))]))
[[] #{}] calls)))
(defn- finish-reply
"The reply is complete. With no calls, that's it. With calls, runs them (::call-tools) — except
blocked ones (blocked-calls), refused without running — unless this turn has already used all
its tool calls (max-tool-calls-per-turn), in which case the turn is stopped instead."
[db]
(let [{:keys [pending-calls tool-calls-used]} (:chat db)
used (+ (or tool-calls-used 0) (count pending-calls))
page (:page db)
once (model-context/once-per-turn-names page)
calls (blocked-calls once (get-in db [:chat :tools-used-this-turn]) pending-calls)
newly-used (into #{} (comp (remove :blocked?) (map :name) (filter once)) calls)
db (update db :chat assoc :pending-calls nil :thinking-at nil)]
(cond
(empty? pending-calls)
(let [db (assoc-in db [:chat :status] :idle)]
{:db db ::persist-chat (save-chat-fx db)})
(> used max-tool-calls-per-turn)
(let [db (-> db
(update-in [:chat :messages] with-tool-calls pending-calls)
(update-in [:chat :messages] into
(for [{:keys [id name]} pending-calls]
(tool-message {:id id :name name :error? true
:content "not run: too many tool calls in one turn"})))
(update :chat assoc :status :idle
:error "The assistant made too many tool calls in a row, so it was stopped."))]
{:db db ::persist-chat (save-chat-fx db)})
:else
{:db (-> db
(update-in [:chat :messages] with-tool-calls pending-calls)
(update-in [:chat :tools-used-this-turn] into newly-used)
(assoc-in [:chat :tool-calls-used] used))
::call-tools {:page page :calls calls :on-results [::chat-tool-results]}})))
(defn- text? [x]
(and (string? x) (seq x)))
(defn- start-tool-call [db {:keys [toolCallId toolCallName]}]
(update-in db [:chat :tool-call-buffer] assoc toolCallId {:id toolCallId :name toolCallName :arguments ""}))
(defn- append-tool-call-args [db {:keys [toolCallId delta]}]
(update-in db [:chat :tool-call-buffer toolCallId :arguments] str delta))
(defn- end-tool-call [db {:keys [toolCallId]}]
(let [call (get-in db [:chat :tool-call-buffer toolCallId])]
(cond-> db
call (-> (update-in [:chat :pending-calls] (fnil conj []) call)
(update-in [:chat :tool-call-buffer] dissoc toolCallId)))))
;; One AG-UI event of the reply (tbd.chat.routes, https://docs.ag-ui.com): TEXT_MESSAGE_CONTENT
;; and REASONING_MESSAGE_CONTENT append to the reply's :content/:thinking, TOOL_CALL_START/ARGS/END
;; build up :tool-call-buffer, and RUN_FINISHED/RUN_ERROR end the turn. Events nobody is waiting
;; for (the conversation was reset since) are dropped.
(rf/reg-event-fx
::chat-event
[(rf/inject-cofx ::now)]
(fn [{:keys [db now]} [_ {:keys [type] :as event}]]
(let [loading? (= :loading (get-in db [:chat :status]))
db (cond-> db
(and loading? (= "REASONING_MESSAGE_CONTENT" type) (text? (:delta event)))
(assoc-in [:chat :thinking-at] now))]
(cond
(not loading?) {:db db}
(= "TEXT_MESSAGE_CONTENT" type) {:db (append-to-reply db (:delta event))}
(= "REASONING_MESSAGE_CONTENT" type)
{:db (cond-> db (text? (:delta event)) (append-reasoning (:delta event)))}
(= "TOOL_CALL_START" type) {:db (start-tool-call db event)}
(= "TOOL_CALL_ARGS" type) {:db (append-tool-call-args db event)}
(= "TOOL_CALL_END" type) {:db (end-tool-call db event)}
(= "RUN_FINISHED" type) (finish-reply db)
(= "RUN_ERROR" type) (let [db (chat-failed db (:message event))]
{:db db ::persist-chat (save-chat-fx db)})
:else {:db db}))))
(def ^:private blocked-message
"not run: this only runs once per message, and already has this turn — answer instead of calling it again")
(defn- call-all
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. Run one after
the other (a tool may need the page the last one left). A call marked :blocked? by blocked-calls
never reaches the page."
[page calls]
(reduce (fn [results {:keys [id name arguments blocked?]}]
(.then results
(fn [done]
(if blocked?
(conj done {:id id :name name :content blocked-message :error? true})
(.then (model-context/call! page name arguments)
(fn [{:keys [text error?]}]
(conj done {:id id :name name :content (display-text text) :error? error?})))))))
(js/Promise.resolve [])
calls))
;; Runs the LLM's tool calls on `page`'s tools, and dispatches `(conj on-results results)` when
;; done: one {:id :name :content :error?} per call. A call that can't be made (unknown tool, bad
;; arguments, a tool that throws) comes back as an :error? result, for the LLM to read.
(rf/reg-fx
::call-tools
(fn [{:keys [page calls on-results]}]
(.then (call-all page calls) #(rf/dispatch (conj on-results %)))))
(defn- answers?
"Whether `results` answer the calls the conversation is waiting on (not a stale response after
the conversation was reset while the tools ran)."
[db results]
(let [calls (:tool-calls (peek (get-in db [:chat :messages])))]
(and (= :loading (get-in db [:chat :status]))
(seq calls)
(= (map :id calls) (map :id results)))))
(rf/reg-event-fx
::chat-tool-results
(fn [{:keys [db]} [_ results]]
(if-not (answers? db results)
{:db db}
(let [db (update-in db [:chat :messages] into (map tool-message) results)]
{:db db
::fetch-stream (chat-request db (get-in db [:chat :messages]))}))))
(def ^:private halted-result
"(halted by the user before the result came back: this call may or may not have taken effect)")
;; Marks the reply :halted? and answers any in-flight tool calls with halted-result, since the LLM
;; refuses a call left unanswered.
(defn- halt-reply [messages]
(let [{:keys [role tool-calls]} (peek messages)]
(cond
(not= "assistant" role)
(conj messages {:role "assistant" :content "" :halted? true})
(seq tool-calls)
(into (update messages (dec (count messages)) assoc :halted? true)
(for [{:keys [id name]} tool-calls]
(tool-message {:id id :name name :error? true :content halted-result})))
:else (update messages (dec (count messages)) assoc :halted? true))))
;; The user halts a reply mid-way, to steer it with the next message: stops the stream
;; (::abort-stream), and marks what came so far :halted? (see halt-reply) instead of discarding it.
(rf/reg-event-fx
::chat-halt
(fn [{:keys [db]} _]
(if-not (= :loading (get-in db [:chat :status]))
{:db db}
(let [db (-> db
(update-in [:chat :messages] halt-reply)
(update :chat assoc :status :idle :error nil :pending-calls nil
:tool-call-buffer {} :thinking-at nil))]
{:db db
::abort-stream true
::persist-chat (save-chat-fx db)}))))
;; Starts a new session (not while a reply is in flight), clearing the stored history too.
(rf/reg-event-fx
::chat-clear
(fn [{:keys [db]} _]
(if (= :loading (get-in db [:chat :status]))
{:db db}
{:db (reset-chat db)
::persist-chat {:uri "/api/chat/history" :method "DELETE" :on-response [::clear-chat-history-response]}})))
(rf/reg-event-db
::clear-chat-history-response
(fn [db _] db))
;; --- MCP setup page ---
;; Puts `text` on the clipboard. Requires a secure origin (https or localhost); failures are
;; ignored.
(rf/reg-fx
::copy-to-clipboard
(fn [text]
@@ -192,16 +800,19 @@
;; --- Tic-tac-toe ---
;; An illegal move (taken cell, game over) changes nothing.
(rf/reg-event-db
(rf/reg-event-fx
::ttt-move
(fn [db [_ i]]
(fn [{:keys [db]} [_ i]]
(let [{:keys [board turn]} (:ttt db)]
(if-let [board' (tictactoe/move board turn i)]
(assoc db :ttt {:board board' :turn (tictactoe/next-player turn)})
db))))
(let [ttt {:board board' :turn (tictactoe/next-player turn)}]
{:db (assoc db :ttt ttt)
::persist-ttt ttt})
{:db db}))))
(rf/reg-event-db
(rf/reg-event-fx
::ttt-reset
(fn [db _]
(assoc db :ttt (:ttt db/default-db))))
(fn [{:keys [db]} _]
(let [ttt (:ttt db/default-db)]
{:db (assoc db :ttt ttt)
::persist-ttt ttt})))
+189
View File
@@ -0,0 +1,189 @@
(ns tbd.ui.markdown
"Turns a chat message's Markdown into Reagent hiccup, for `chat-bubble` to show as blocks
(headings, lists, code, blockquotes, tables) and inline formatting (bold, italic, code, links)
instead of flat text. Hand-rolled rather than an npm library: not full CommonMark (no nested
lists, and a table or list has to start right after a blank line, not mid-paragraph), but
covers what a chat message actually uses.
No HTML is ever built as a string and injected (no :dangerouslySetInnerHTML, so nothing to run
a sanitizer library over either): every leaf here is a plain Clojure string, which Reagent
turns into a text node the same way any other hiccup content is, so it can never be read back
as markup. The one place a message's text becomes an attribute rather than a text node is a
link's `href`, which `safe-href` checks by hand."
(:require [clojure.string :as str]))
;; --- Block matchers (tested against a left-trimmed line) ---
(def ^:private fence-re #"^```\s*(\S*)\s*$")
(def ^:private fence-close-re #"^\s*```\s*$")
(def ^:private heading-re #"^(#{1,6})\s+(.*)$")
(def ^:private hr-re #"^(?:-{3,}|\*{3,}|_{3,})\s*$")
(def ^:private quote-re #"^>\s?(.*)$")
(def ^:private ul-re #"^[-*+]\s+(.*)$")
(def ^:private ol-re #"^\d+[.)]\s+(.*)$")
(def ^:private table-sep-re #"^\|?\s*:?-+:?\s*(\|\s*:?-+:?\s*)*\|?\s*$")
(defn- block-starter?
"Whether `line` begins a block of its own, so a paragraph reading lines one at a time stops
before it even without a blank line in between."
[line]
(let [l (str/triml line)]
(boolean (or (str/blank? l) (re-find fence-re l) (re-find heading-re l) (re-find hr-re l)
(re-find quote-re l) (re-find ul-re l) (re-find ol-re l)))))
;; --- Inline formatting ---
(def ^:private allowed-schemes #{"http" "https" "mailto" "tel"})
(defn- safe-href
"`url` if it's fine to put in an href (no scheme, i.e. relative, or one of `allowed-schemes`),
else nil: the model can write a `javascript:` link too, whether it means to or not (quoting one
from a tool result), and React itself won't stop that from running on a click."
[url]
(let [scheme (second (re-find #"^([A-Za-z][A-Za-z0-9+.-]*):" url))]
(when (or (nil? scheme) (contains? allowed-schemes (str/lower-case scheme)))
url)))
(defn- flanked?
"Whether `s` is a fit inside for an emphasis/strong span: not empty, and not padded with a
space, which is usually a stray `*` or `_` doing something else (\"3 * 4 * 5\") rather than
marking emphasis."
[s]
(and (seq s) (not (str/starts-with? s " ")) (not (str/ends-with? s " "))))
(def ^:private link-re #"^\[([^\]]*)\]\(([^)\s]+)(?:\s+\"[^\"]*\")?\)")
(defn- flush-text
"`out` with the literal text `s[from, to)` appended, if there is any."
[out s from to]
(if (< from to) (conj out (subs s from to)) out))
(defn- inline-line->hiccup
"One line's worth of inline Markdown (no newlines: see `inline->hiccup` for those) as a vector
of hiccup children: plain strings and `:code`/`:strong`/`:em`/`:a` elements."
[s]
(let [n (count s)]
(loop [i 0, flush 0, out []]
(if (>= i n)
(flush-text out s flush n)
(let [c (subs s i (inc i))
two (when (<= (+ i 2) n) (subs s i (+ i 2)))]
(cond
(= c "`")
(if-let [j (str/index-of s "`" (inc i))]
(recur (inc j) (inc j) (conj (flush-text out s flush i) [:code (subs s (inc i) j)]))
(recur (inc i) flush out))
(contains? #{"**" "__"} two)
(let [j (str/index-of s two (+ i 2))
inner (when j (subs s (+ i 2) j))]
(if (flanked? inner)
(recur (+ j 2) (+ j 2)
(conj (flush-text out s flush i) (into [:strong] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(contains? #{"*" "_"} c)
(let [j (str/index-of s c (inc i))
inner (when j (subs s (inc i) j))]
(if (flanked? inner)
(recur (inc j) (inc j)
(conj (flush-text out s flush i) (into [:em] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(= c "[")
(if-let [[whole label url] (re-find link-re (subs s i))]
(let [href (safe-href url)
label-pieces (inline-line->hiccup label)
node (if href
(into [:a {:href href :target "_blank" :rel "noopener noreferrer"}] label-pieces)
(into [:span] label-pieces))]
(recur (+ i (count whole)) (+ i (count whole)) (conj (flush-text out s flush i) node)))
(recur (inc i) flush out))
:else (recur (inc i) flush out)))))))
(defn- inline->hiccup
"`text` (possibly several lines: a paragraph's or a blockquote line's own soft-wrapped lines)
as hiccup children, a `:br` between each line, the way a bare newline reads in a chat message
someone typed without Markdown's blank-line-between-paragraphs convention in mind."
[text]
(vec (apply concat (interpose [[:br]] (map inline-line->hiccup (str/split text #"\n"))))))
;; --- Blocks ---
(defn- code-block [lang lines]
[:pre [:code (if (seq lang) {:class (str "language-" lang)} {}) (str/join "\n" lines)]])
(defn- table-cells [line]
(->> (-> (str/trim line)
(str/replace #"^\|" "")
(str/replace #"\|$" "")
(str/split #"\|"))
(mapv str/trim)))
(defn- table [header-line body-lines]
(let [header (table-cells header-line)
rows (mapv table-cells body-lines)]
[:table
[:thead (into [:tr] (map #(into [:th] (inline-line->hiccup %)) header))]
(into [:tbody] (map (fn [row] (into [:tr] (map #(into [:td] (inline-line->hiccup %)) row))) rows))]))
(declare parse-blocks)
(defn- parse-blocks
"`text`'s block-level structure, as a vector of hiccup elements."
[text]
(loop [lines (vec (str/split text #"\n")), out []]
(if (empty? lines)
out
(let [line (first lines)
trimmed (str/triml line)]
(cond
(str/blank? trimmed) (recur (subvec lines 1) out)
(re-find fence-re trimmed)
(let [lang (second (re-find fence-re trimmed))
rest-lines (subvec lines 1)
close (first (keep-indexed #(when (re-find fence-close-re %2) %1) rest-lines))
end (or close (count rest-lines))]
(recur (subvec rest-lines (min (count rest-lines) (inc end)))
(conj out (code-block lang (subvec rest-lines 0 end)))))
(re-find heading-re trimmed)
(let [[_ hashes content] (re-find heading-re trimmed)]
(recur (subvec lines 1)
(conj out (into [(keyword (str "h" (count hashes)))] (inline-line->hiccup content)))))
(re-find hr-re trimmed) (recur (subvec lines 1) (conj out [:hr]))
(re-find quote-re trimmed)
(let [quoted (take-while #(re-find quote-re (str/triml %)) lines)
inner (str/join "\n" (map #(second (re-find quote-re (str/triml %))) quoted))]
(recur (subvec lines (count quoted)) (conj out (into [:blockquote] (parse-blocks inner)))))
(re-find ul-re trimmed)
(let [items (take-while #(re-find ul-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ul] (map #(into [:li] (inline-line->hiccup (second (re-find ul-re (str/triml %)))))
items)))))
(re-find ol-re trimmed)
(let [items (take-while #(re-find ol-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ol] (map #(into [:li] (inline-line->hiccup (second (re-find ol-re (str/triml %)))))
items)))))
(and (str/includes? trimmed "|") (> (count lines) 1)
(re-find table-sep-re (str/triml (second lines))))
(let [body (->> (subvec lines 2) (take-while #(str/includes? (str/triml %) "|")))]
(recur (subvec lines (+ 2 (count body))) (conj out (table trimmed body))))
:else
(let [para (take-while (complement block-starter?) lines)]
(recur (subvec lines (count para))
(conj out (into [:p] (inline->hiccup (str/join "\n" (map str/trim para))))))))))))
(defn render
"`text` (Markdown, possibly blank) as a Reagent fragment, ready to use as a hiccup child."
[text]
(into [:<>] (parse-blocks (str/trim (or text "")))))
+122
View File
@@ -0,0 +1,122 @@
(ns tbd.ui.model-context
"The registry of tools the page's own chatbot offers its LLM, mirroring WebMCP's
`navigator.modelContext` (tbd.ui.core registers tbd.ui.webmcp's tools here too). The chatbot
sends `definitions` (MCP's `tools/list` shape) with the conversation; tbd.ui.events intercepts
the LLM's requested calls and runs them via `call!`, right here in the page.
A tool is {:name :description :input-schema :handler :pages}. `handler` takes a map of
arguments and returns a value or promise of one (a string as-is, other data as JSON; throwing is
an error result). `pages` (tbd.ui.pages) is where the tool is offered; omitted means every page.
State providers ({:pages :provide}) are the same idea for ambient state: tbd.ui.events attaches
`(current-state page)` to every /api/chat request (tbd.chat.schema/RunAgentInput's `state`), so
the model sees what the page shows without spending a call to read it."
(:require [clojure.string :as str]))
(defonce ^:private registry (atom []))
(defonce ^:private state-registry (atom []))
(defn register!
"Adds `tools` to what the page offers. A tool with the name of one already there replaces it
(which is what makes registering again, on hot reload, safe)."
[tools]
(let [names (set (map :name tools))]
(swap! registry (fn [registered] (into (filterv #(not (names (:name %))) registered) tools)))
nil))
(defn clear!
"Takes every tool and state provider away: for a test to start from a page that offers none."
[]
(reset! registry [])
(reset! state-registry [])
nil)
(defn- offered?
"Whether `entry` (a tool or a state provider) is offered on `page`."
[page {:keys [pages]}]
(or (nil? pages) (contains? pages page)))
(defn definitions
"What the LLM is told about the tools offered on `page`, as MCP's `tools/list` gives them:
[{:name :description :inputSchema}], in the order they were registered. A `:read-only?` tool
(one that only reads what `current-state` already covers, like list_todos) is left out: the
chatbot is handed the state instead of a call to read it, but the tool stays registered for
WebMCP, whose outside agents have no state channel to fall back on."
[page]
(into []
(comp (filter #(offered? page %))
(remove :read-only?)
(map (fn [{:keys [name description input-schema]}]
(cond-> {:name name :inputSchema input-schema}
description (assoc :description description)))))
@registry))
(defn once-per-turn-names
"The names of the tools offered on `page` that do something only one message's worth of
chaining can call for (like a game move — the person asking again is what asks for another one,
not the model on its own): tbd.ui.events stops offering, and stops running, one of these again
once it has run once in the current turn."
[page]
(into #{} (comp (filter #(offered? page %)) (filter :once-per-turn?) (map :name)) @registry))
(defn register-state!
"Replaces what the page offers as state with `providers` ({:pages :provide}, see this ns's
docstring). Unlike `register!`'s tools (registered piecemeal, by name, from more than one
caller), there is one caller (tbd.ui.core) and one list, so registering again — hot reload —
just replaces it, rather than needing a name to replace by."
[providers]
(reset! state-registry (vec providers))
nil)
(defn current-state
"What `page` shows right now, as one map: every state provider offered on it, merged (later ones
win a key both share, though none do today). {} when nothing is registered for it, or nothing
goes to the LLM (tbd.ui.events omits an empty state rather than sending it)."
[page]
(transduce (comp (filter #(offered? page %)) (map (fn [{:keys [provide]}] (provide))))
merge {} @state-registry))
(defn- ->text [value]
(cond
(string? value) value
(nil? value) "ok"
:else (js/JSON.stringify (clj->js value))))
(defn run
"A promise of the result of `handler` on `args`, as {:text string :error? bool}. It never
rejects: a handler that throws, or whose promise rejects, is an error result."
[handler args]
(-> (js/Promise.resolve)
(.then #(handler args))
(.then (fn [value] {:text (->text value) :error? false}))
(.catch (fn [e] {:text (or (some-> e (aget "message")) (str e)) :error? true}))))
(defn- parse-arguments
"The arguments the LLM wrote, JSON text, as a map: nothing at all is no arguments (a model
calls a tool that takes none that way). Anything but a JSON object gives ::invalid."
[text]
(if (str/blank? text)
{}
(let [parsed (try (js->clj (js/JSON.parse text) :keywordize-keys true)
(catch :default _ ::invalid))]
(if (map? parsed) parsed ::invalid))))
(defn- failed [text]
(js/Promise.resolve {:text text :error? true}))
(defn call!
"Calls the tool `tool-name` on `arguments`, the JSON text the LLM wrote, and gives a promise of
its result, as {:text string :error? bool}. A tool that isn't there or isn't offered on `page`
(the LLM may be going by an earlier page's tools), or arguments that aren't a JSON object, is an
error result the LLM can read and try again from."
[page tool-name arguments]
(let [tool (first (filter #(= tool-name (:name %)) @registry))
args (parse-arguments arguments)]
(cond
(nil? tool) (failed (str "unknown tool: " tool-name))
(not (offered? page tool)) (failed (str "tool not available on this page: " tool-name
" (it is offered on the "
(str/join ", " (map name (sort (:pages tool))))
" page)"))
(= ::invalid args) (failed "invalid arguments: they must be a JSON object")
:else (run (:handler tool) args))))
+28
View File
@@ -0,0 +1,28 @@
(ns tbd.ui.pages
"The pages of the app, and how they map to the URL. The server only serves the shell at `/`,
so a page lives in the fragment (`/#/todos`): following a link between pages never asks the
server for anything, and a page can still be bookmarked or reloaded.")
(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 :tic-tac-toe :title "Tic-tac-toe"}
{:id :calculator :title "Calculator"}
{:id :todos :title "Todos" :login? true}
{:id :ai-setup :title "AI setup"}])
(def default-page (:id (first pages)))
(def ^:private ids (into #{} (map :id) pages))
(defn page->hash
"The fragment that opens `page`: \"#/todos\"."
[page]
(str "#/" (name page)))
(defn hash->page
"The page a fragment (with or without its leading #) opens; the default page when it is empty
or names no page."
[hash]
(let [id (keyword (second (re-find #"^#?/?([^/?]*)" (or hash ""))))]
(if (contains? ids id) id default-page)))
+23
View File
@@ -0,0 +1,23 @@
(ns tbd.ui.sse
"Reading server-sent events (what POST /api/chat answers with) out of the text that arrives in
pieces. Pure: tbd.ui.events does the fetching and feeds the pieces in."
(:require [clojure.string :as str]))
(defn- event-data
"The data of one event (the lines between blank lines) as a map, or nil when there is none
(a comment, say) or it isn't JSON."
[block]
(let [data (->> (str/split-lines block)
(keep #(second (re-matches #"data: ?(.*)" %))))]
(when (seq data)
(try (js->clj (js/JSON.parse (str/join "\n" data)) :keywordize-keys true)
(catch :default _ nil)))))
(defn parse
"`text` is what has been received so far and hasn't been parsed yet. Returns [events rest]: the
events that are complete in it (each the JSON of its `data:` lines, as a map), and the end of it,
an event that hasn't fully arrived, to put in front of the next piece."
[text]
(let [blocks (str/split (str/replace text "\r\n" "\n") #"\n\n" -1)]
[(vec (keep event-data (butlast blocks)))
(last blocks)]))
+2
View File
@@ -2,10 +2,12 @@
(:require [re-frame.core :as rf]
[tbd.ui.tictactoe :as tictactoe]))
(rf/reg-sub ::page (fn [db _] (:page db)))
(rf/reg-sub ::operand (fn [db [_ k]] (get-in db [:calc k])))
(rf/reg-sub ::result (fn [db _] (get-in db [:calc :result])))
(rf/reg-sub ::user (fn [db _] (:user db)))
(rf/reg-sub ::todos (fn [db _] (:todos db)))
(rf/reg-sub ::chat (fn [db _] (:chat db)))
(rf/reg-sub ::mcp-copied? (fn [db _] (get-in db [:mcp :copied?])))
(rf/reg-sub ::ttt (fn [db _] (:ttt db)))
+343 -32
View File
@@ -1,7 +1,10 @@
(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.markdown :as markdown]
[tbd.ui.pages :as pages]
[tbd.ui.subs :as subs]
[tbd.ui.webmcp :as webmcp]))
@@ -23,15 +26,17 @@
"Sends GET /api/add?x=..&y=.. on submit and shows the sum the server returns."
[]
(let [result @(rf/subscribe [::subs/result])]
[:form {:on-submit (fn [e]
(.preventDefault e)
(rf/dispatch [::events/add]))}
[:div {:style {:display "flex" :gap "1rem" :align-items "center"}}
[operand-input :x "x"]
"+"
[operand-input :y "y"]
[:button {:type "submit" :disabled (= :loading (:status result))} "Add"]]
[result-line result]]))
[:section
[:h2 "Calculator"]
[:form {:on-submit (fn [e]
(.preventDefault e)
(rf/dispatch [::events/add]))}
[:div {:style {:display "flex" :gap "1rem" :align-items "center"}}
[operand-input :x "x"]
"+"
[operand-input :y "y"]
[:button {:type "submit" :disabled (= :loading (:status result))} "Add"]]
[result-line result]]]))
(defn- todo-item [{:keys [id title done]}]
[:li {:style {:display "flex" :gap "0.5rem" :align-items "center" :margin "0.25rem 0"}}
@@ -52,7 +57,7 @@
^{:key (:id todo)} [todo-item todo])]))
(defn todos
"Your todos (GET/POST /api/todos, PATCH/DELETE /api/todos/:id). Only shown when logged in."
"Your todos (GET/POST /api/todos, PATCH/DELETE /api/todos/:id)."
[]
(let [{:keys [new-title error] :as state} @(rf/subscribe [::subs/todos])]
[:section
@@ -105,20 +110,13 @@
[]
(str "claude mcp add --transport http tbd " js/location.origin "/mcp"))
(defn- collapsible
"A section the reader can fold away by its heading (a native <details>, closed to start with)."
[title & body]
(into [:details {:style {:margin-top "2rem"}}
[:summary {:style {:cursor "pointer"}}
[:h2 {:style {:display "inline"}} title]]]
body))
(defn mcp-setup
"How to add this server to Claude Code: a command to copy, then signing in once."
[]
(let [command (mcp-command)
copied? @(rf/subscribe [::subs/mcp-copied?])]
[collapsible "Add this MCP server to Claude Code"
[:section
[:h2 "Add this MCP server to Claude Code"]
[:p "Run this in your terminal:"]
[:div {:style {:display "flex" :gap "0.5rem" :align-items "flex-start"}}
[:pre {:style {:flex 1 :margin 0 :padding "0.75rem" :overflow-x "auto"
@@ -139,7 +137,8 @@
"The page's own tools for a browser agent (WebMCP, see tbd.ui.webmcp): how to connect an MCP
client to them. The token is pasted into the WebMCP widget in the corner of the page."
[]
[collapsible "Browser tools (WebMCP)"
[:section
[:h2 "Browser tools (WebMCP)"]
[:p "This page offers " [:strong (count webmcp/tools)] " tools of its own (the calculator, the todos and the tic-tac-toe game) to "
"your MCP client, over " [:a {:href "https://webmcp.dev" :target "_blank" :rel "noreferrer"} "WebMCP"]
", and you see them work on the page. To connect:"]
@@ -168,16 +167,328 @@
"Log out"]
nil))
(defn- login-prompt
"What the todos page says to someone who isn't logged in (nothing while we don't know yet)."
[{:keys [status message]}]
(case status
:anonymous [:section
[:h2 "Todos"]
[:p [:a {:href "/auth/login"} "Log in"] " to see your todos."]]
:error [:p {:role "alert" :style {:color "crimson"}} message]
nil))
(def ^:private chat-green "#28a745")
;; Spacing/border defaults for Markdown blocks (tbd.ui.markdown) inside a bubble, plus a low-alpha
;; overlay for code/rules that reads on both the green and grey bubble colors. Global (not scoped
;; to one bubble), but "chat-markdown" is specific enough not to collide with the rest of the page.
(defn- chat-markdown-style []
[:style "
.chat-markdown > :first-child { margin-top: 0; }
.chat-markdown > :last-child { margin-bottom: 0; }
.chat-markdown p, .chat-markdown ul, .chat-markdown ol, .chat-markdown pre,
.chat-markdown blockquote, .chat-markdown table, .chat-markdown h1, .chat-markdown h2,
.chat-markdown h3 { margin: 0 0 0.5em; }
.chat-markdown ul, .chat-markdown ol { padding-left: 1.25em; }
.chat-markdown li { margin: 0.15em 0; }
.chat-markdown pre { padding: 0.5em; overflow-x: auto; background: rgba(0,0,0,0.08); border-radius: 0.35em; }
.chat-markdown code { font-family: monospace; font-size: 0.85em; }
.chat-markdown pre code { background: none; padding: 0; }
.chat-markdown :not(pre) > code { background: rgba(0,0,0,0.1); padding: 0.1em 0.3em; border-radius: 0.25em; }
.chat-markdown blockquote { padding-left: 0.6em; border-left: 2px solid currentColor; opacity: 0.85; }
.chat-markdown table { border-collapse: collapse; }
.chat-markdown th, .chat-markdown td { border: 1px solid currentColor; padding: 0.2em 0.5em; }
.chat-markdown a { color: inherit; text-decoration: underline; }
"])
(defn- chat-bubble [{:keys [role content]}]
(let [user? (= "user" role)]
[:div {:class "chat-markdown"
:style {:align-self (if user? "flex-end" "flex-start")
:max-width "85%" :padding "0.4rem 0.6rem" :border-radius "0.5rem"
:overflow-wrap "anywhere"
:background (if user? chat-green "#f1f1f1")
:color (if user? "white" "#222")}}
(markdown/render content)]))
(defn- chat-tool-line
"A tool the assistant calls, or what came of it, apart from what is said, and in smaller print.
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]}]
(str "Calling " name (when-not (str/blank? arguments) (str " " arguments)) "…"))
(defn- result-text [{:keys [name content error?]}]
(str name (if error? " failed: " " → ") content))
(defn- chat-reasoning-block
"A reply's reasoning, whole (never cut down, unlike a tool line): shown only with \"Show
reasoning\" on, and then all of it, for whichever reply it belongs to."
[text]
[:div {:data-reasoning true
:style {:align-self "flex-start" :max-width "85%" :flex-shrink 0
:overflow-wrap "anywhere" :white-space "pre-wrap"
:font-family "monospace" :font-size "12px" :font-style "italic" :color "#777"}}
text])
(defn- chat-message
"What was said, as a bubble, and the tool calls the assistant made with it, and their results,
as lines between the bubbles. The reasoning behind a reply, if any, shows above it, whole, only
when `reasoning-expanded?`."
[tools-expanded? reasoning-expanded? {:keys [role content tool-calls thinking halted?] :as message}]
(if (= "tool" role)
[chat-tool-line tools-expanded? (result-text message) message]
[:<>
(when (and reasoning-expanded? (not (str/blank? thinking))) [chat-reasoning-block thinking])
(when-not (str/blank? content) [chat-bubble message])
(for [call tool-calls]
^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])
(when halted?
[:div {:data-halted true
:style {:align-self "flex-start" :font-size "12px" :font-style "italic" :color "#777"}}
"Stopped"])]))
(defn- tool-use?
"Whether the conversation has any tool call or result."
[messages]
(some #(or (= "tool" (:role %)) (seq (:tool-calls %))) messages))
(defn- reasoning-use?
"Whether the conversation has any reasoning to show."
[messages]
(some (comp not str/blank? :thinking) messages))
(defn- reply-pending?
"Whether `message` (the last of the conversation) has yet to become the reply: it isn't the
assistant's yet, or, now that reasoning joins the conversation as it comes (see
::events/chat-event), it is an assistant message that is still only that reasoning — no content
said, no tool calls asked for. \"Thinking…\" shows for as long as this holds."
[{:keys [role content tool-calls]}]
(or (not= "assistant" role)
(and (str/blank? content) (empty? tool-calls))))
(def ^:private chat-min-width 260)
(def ^:private chat-min-height 96)
;; What the panel has besides the conversation (header, form, padding, and the gap under the
;; window's top edge it keeps): the conversation can be as high as the window less this.
(def ^:private chat-chrome-height 220)
(def ^:private stuck-slack
"How far (px) from its end the conversation can be scrolled and still count as at its end."
24)
(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))]
;; The dots sit in a box of their own fixed width, so what follows (the stop button) stays put
;; however many there are.
[:div {:role "status" :style {:color "#777"}}
"Thinking"
[:span {:style {:display "inline-block" :width "1.2em"}}
(if live?
(apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) "."))
"…")]])
(finally (js/clearInterval timer))))
(defn- halt-button
"The little square that stops the reply (see ::events/chat-halt), so the next message can steer it."
[]
[:button {:type "button" :aria-label "Stop" :title "Stop the reply"
:on-click #(rf/dispatch [::events/chat-halt])
:style {:display "inline-flex" :align-items "center" :justify-content "center"
:width "1.25rem" :height "1.25rem" :padding 0 :cursor "pointer"
:border "1px solid #bbb" :border-radius "50%" :background "white"}}
[:span {:style {:width "0.5rem" :height "0.5rem" :background "#777" :border-radius "1px"}}]])
(defn- chat-log
"The conversation, which follows its end (as the pieces of a reply come in) for as long as it is
scrolled to it. Scroll up to read back and it stays where it is, until you send a message or
scroll down to the end again (a message sent is among the ones that came since the last render,
which may also hold the first of the reply). \"Thinking…\" shows from the sending until the reply's first piece
(animated while the model's reasoning is coming in), and a stop button beside it, for as long as
the reply is on its way; what the model reasons shows, in full, only
with \"Show reasoning\" on (see chat-reasoning-block)."
[_chat _size]
(let [stuck? (atom true)
seen (atom 0)]
(fn [{:keys [messages status thinking-at tools-expanded? reasoning-expanded?]} {:keys [height]}]
[:div {:role "log" :aria-live "polite"
:ref (fn [el]
(when el
(when (some #(= "user" (:role %)) (drop @seen messages))
(reset! stuck? true))
(reset! seen (count messages))
(when @stuck? (set! (.-scrollTop el) (.-scrollHeight el)))))
:on-scroll #(reset! stuck? (at-end? (.-target %)))
:style {:display "flex" :flex-direction "column" :gap "0.4rem"
:height (str height "px")
:max-height (str "max(" chat-min-height "px, calc(100vh - " chat-chrome-height "px))")
:overflow-y "auto" :margin "0.5rem 0"}}
(if (and (empty? messages) (not= :loading status))
[:p {:style {:color "#777" :margin 0}} "Ask me anything."]
(for [[i message] (map-indexed vector messages)]
^{:key i} [chat-message tools-expanded? reasoning-expanded? message]))
(when (= :loading status)
[:div {:data-pending true
:style {:display "flex" :align-items "center" :gap "0.4rem" :flex-shrink 0}}
(when (reply-pending? (peek messages)) [thinking-line thinking-at])
[halt-button]])])))
(defn- chat-form [{:keys [input status]}]
(let [loading? (= :loading status)]
[:form {:on-submit (fn [e]
(.preventDefault e)
(rf/dispatch [::events/chat-send]))
:style {:display "flex" :gap "0.4rem"}}
;; Not disabled or read-only while waiting, so you can type the next message ahead of the
;; reply; ::chat-send itself ignores a submit while a reply is still loading.
[:input {:type "text" :name "message" :aria-label "Message" :placeholder "Message"
:auto-focus true :auto-complete "off"
:style {:flex 1 :min-width 0}
:value input
:on-change #(rf/dispatch [::events/chat-set-input (.. % -target -value)])}]
[:button {:type "submit" :disabled (or loading? (str/blank? input))} "Send"]]))
(defn- chat-body [{:keys [error size] :as chat} user]
(case (:status user)
:logged-in [:<>
[chat-log chat size]
(when error [:p {:role "alert" :style {:color "crimson" :margin "0 0 0.5rem"}} error])
[chat-form chat]]
:anonymous [:p [:a {:href "/auth/login"} "Log in"] " to chat."]
:error [:p {:role "alert" :style {:color "crimson"}} (:message user)]
nil))
(defn- clamp [lo n hi]
(max lo (min n hi)))
(defn- start-resize!
"The panel is stuck to the bottom left corner, so dragging its top right corner is what makes it
bigger: to the right widens it, up makes the conversation higher. The pointer is followed
through the window, wherever it goes, until it is let go."
[e {:keys [width height]}]
(when (zero? (.-button e))
(.preventDefault e)
(let [x0 (.-clientX e)
y0 (.-clientY e)
move (fn [e]
(rf/dispatch [::events/chat-resize
(clamp chat-min-width (+ width (- (.-clientX e) x0))
(- (.-innerWidth js/window) 40))
(clamp chat-min-height (- height (- (.-clientY e) y0))
(- (.-innerHeight js/window) chat-chrome-height))]))
stop (fn stop [_]
(.removeEventListener js/window "pointermove" move)
(.removeEventListener js/window "pointerup" stop)
(.removeEventListener js/window "pointercancel" stop))]
(.addEventListener js/window "pointermove" move)
(.addEventListener js/window "pointerup" stop)
(.addEventListener js/window "pointercancel" stop))))
(defn- resize-handle [size]
[:div {:role "separator" :aria-label "Resize chat" :title "Drag to resize"
:on-pointer-down #(start-resize! % size)
:style {:position "absolute" :top 0 :right 0 :width "14px" :height "14px"
:cursor "nesw-resize" :touch-action "none"
:background "linear-gradient(225deg, #bbb 0 2px, transparent 2px 5px, #bbb 5px 7px, transparent 7px)"}}])
(defn- chat-panel [{:keys [messages status size tools-expanded? reasoning-expanded?] :as chat} user]
[:div {:role "dialog" :aria-label "Chat"
:style {:position "absolute" :bottom "40px" :left 0 :box-sizing "border-box"
:width (str (:width size) "px")
:max-width "calc(100vw - 40px)" :padding "15px" :background "#fff" :color "#222"
:border "1px solid #e1e1e1" :border-radius "5px"
: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 (reasoning-use? messages)
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-reasoning])}
(if reasoning-expanded? "Hide reasoning" "Show reasoning")])
(when (and (seq messages) (not= :loading status))
[link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"])
[:button {:type "button" :aria-label "Close chat"
:style {:background "none" :border 0 :font-size "1.25rem" :line-height 1 :cursor "pointer"}
:on-click #(rf/dispatch [::events/chat-toggle])}
"×"]]
[chat-body chat user]
[resize-handle size]])
(defn chat-widget
"A green square in the bottom left corner that opens a chat with the LLM (POST /api/chat), the
way the WebMCP widget's blue square in the other corner opens its connection panel. The LLM can
use the page's tools (tbd.ui.model-context): the panel shows the calls it makes. Chat needs a
login, so someone who isn't logged in is asked to log in."
[]
(let [{:keys [open?] :as chat} @(rf/subscribe [::subs/chat])
user @(rf/subscribe [::subs/user])]
[:div {:style {:position "fixed" :left "20px" :bottom "20px" :z-index 9999
:font-family "Arial, sans-serif" :font-size "14px"}}
[chat-markdown-style]
(when open? [chat-panel chat user])
[:button {:type "button" :aria-label "Chat" :title "Chat" :aria-expanded (boolean open?)
:style {:display "block" :width "30px" :height "30px" :padding 0 :border 0
:border-radius "4px" :cursor "pointer" :background chat-green
:box-shadow "0 2px 10px rgba(0,0,0,0.2)"}
:on-click #(rf/dispatch [::events/chat-toggle])}]]))
(defn- current-page [page user]
(case page
:tic-tac-toe [tic-tac-toe]
:calculator [calculator]
:todos (if (= :logged-in (:status user)) [todos] [login-prompt user])
:ai-setup [:<> [mcp-setup] [browser-tools]]))
(defn- tabs
"One link per page, the current one marked. The todos are only offered when logged in."
[current user]
[:nav {:aria-label "Pages" :style {:display "flex" :flex-wrap "wrap" :gap "1rem"
:border-bottom "1px solid GrayText" :padding-bottom "0.5rem"}}
(for [{:keys [id title login?]} pages/pages
:when (or (not login?) (= :logged-in (:status user)))]
^{:key id}
[:a (cond-> {:href (pages/page->hash id)}
(= id current) (assoc :aria-current "page" :style {:font-weight "bold"}))
title])])
(defn app []
(let [user @(rf/subscribe [::subs/user])]
[:main {:style {:font-family "system-ui, sans-serif" :max-width "40rem" :margin "2rem auto"}}
[:h1 "tbd"]
[calculator]
(when (= :logged-in (:status user))
[todos])
[tic-tac-toe]
[mcp-setup]
[browser-tools]
[:p [:a {:href "/api-docs"} "API docs"] " · " [:a {:href "/swagger.json"} "swagger.json"]
(when-let [link (auth-link user)]
[:<> " · " link])]]))
(let [page @(rf/subscribe [::subs/page])
user @(rf/subscribe [::subs/user])]
[:<>
[:main {:style {:font-family "system-ui, sans-serif" :max-width "40rem" :margin "2rem auto"}}
[:h1 "tbd"]
[tabs page user]
[current-page page user]
[:p {:style {:margin-top "2rem"}}
[:a {:href "/api-docs"} "API docs"] " · " [:a {:href "/swagger.json"} "swagger.json"]
(when-let [link (auth-link user)]
[:<> " · " link])]]
[chat-widget]]))
+315 -118
View File
@@ -1,19 +1,26 @@
(ns tbd.ui.webmcp
"The page's own MCP tools, for an agent running in the browser: the client-side counterpart of
tbd.mcp.tools. They are offered through WebMCP (https://webmcp.dev, the `@jason.today/webmcp`
library): it adds a small widget to the page, the user pastes a token from their MCP client
(Claude) into it, and the client then sees the tools registered here. Where tbd.mcp.tools works
on the server's data, these work the UI: each one does what a user could do on the page (type in
the form, press a button, tick a box) by dispatching the same re-frame events the views do, so
everything shows on screen, and reads what the page shows from the app-db.
tbd.mcp.tools, offered through WebMCP (https://webmcp.dev). Each tool does what a user could do
on the page (type in a form, press a button) by dispatching the same re-frame events the views
do, and reads results from the app-db. A tool takes a map of arguments and returns a value or a
promise of one (a string, or data that becomes JSON); throwing becomes an error result.
A tool takes its arguments as a map and returns a value or a promise of one: a string, or data
that becomes JSON. Throwing (or rejecting) becomes an error result the agent can read. Input
schemas are JSON Schema, written here: the UI has no Malli to share with the server's."
`tools` also feeds tbd.ui.model-context (via tbd.ui.core), which offers the page's chatbot the
same tools. `:read-only? true` tools are left out there — the chatbot gets that information as
ambient state instead (`state-providers`) — but stay registered here for WebMCP's outside
agents. `:once-per-turn? true` tools (e.g. move_tic_tac_toe) are offered to the chatbot only
until used once per turn (tbd.ui.events); that cap doesn't apply to WebMCP's outside agents.
`prompts` and `resources` carry the same instructions as the chatbot's system prompt
(tbd.agent.prompt), so an outside MCP client is told to act instead of offer, chain calls, etc."
(:require ["@jason.today/webmcp/src/webmcp.js" :as WebMCP]
[clojure.string :as str]
[re-frame.core :as rf]
[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]
[tbd.ui.tictactoe :as tictactoe]))
;; --- Reading and waiting for the app-db ---
@@ -26,6 +33,12 @@
(defn- fail! [message] (throw (js/Error. message)))
(defn- show!
"Opens `page` (see tbd.ui.pages), the way a user would click its tab, so a tool that acts on
the page does it where it can be seen."
[page]
(rf/dispatch-sync [::events/navigate page]))
(defn- settled
"A promise of the app-db as soon as `(pred db)` holds (right away if it already does), or a
rejection after `timeout-ms`. Requests made by events finish some time after the event is
@@ -52,16 +65,22 @@
(-> (settled #(not= :unknown (get-in % [:user :status])) "the login state")
(.then #(:user %))))
(defn- logged-in-todos
"A promise of the todo list as the page shows it, or a rejection if there is no login (the page
hides the todos then) or the list could not be loaded."
[]
(defn- logged-in!
"A promise that is fulfilled once the page knows someone is logged in, or rejected if no one is
(`what` is what needs the login: the page hides it then) or the page can't tell."
[what]
(-> (known-user)
(.then (fn [{:keys [status message]}]
(case status
:logged-in nil
:anonymous (fail! "not logged in: log in on the page to use the todos")
:error (fail! (str "could not tell who is logged in: " message)))))
:anonymous (fail! (str "not logged in: log in on the page to use " what))
:error (fail! (str "could not tell who is logged in: " message)))))))
(defn- logged-in-todos
"A promise of the todo list as the page shows it, or a rejection if there is no login (the page
hides the todos then) or the list could not be loaded."
[]
(-> (logged-in! "the todos")
(.then #(settled (fn [d] (contains? #{:ok :error} (get-in d [:todos :status]))) "the todos"))
(.then (fn [d]
(let [{:keys [status items error]} (:todos d)]
@@ -86,18 +105,58 @@
(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 ---
(defn- ping [_] "pong")
(defn- navigate
"Opens a page, as a click on its tab would."
[{:keys [page]}]
(let [{:keys [id title login?] :as target} (when (string? page)
(first (filter #(= page (name (:id %))) pages/pages)))]
(when-not target
(fail! (str "invalid arguments: page must be one of " (str/join ", " (map (comp name :id) pages/pages)))))
(-> (if login? (logged-in! (str "the " title " page")) (js/Promise.resolve))
(.then (fn [_]
(show! id)
{:page (name id) :title title})))))
(defn- whoami [_]
(-> (known-user)
(.then (fn [{:keys [status login message]}]
@@ -117,6 +176,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! :calculator)
(rf/dispatch-sync [::events/set-operand :x (str x)])
(rf/dispatch-sync [::events/set-operand :y (str y)])
(rf/dispatch-sync [::events/add])
@@ -130,53 +190,81 @@
(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 [_]
(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, and resolves to nil (\"ok\"): the page shows them as they're
added, and the next request's state (tbd.ui.webmcp/state-providers) has them, ids included, so
there is nothing left for the result itself to say."
[{:keys [todos]}]
(check-todos! todos (fn [{:keys [title]}]
(when-not (and (string? title) (seq title))
(fail! "invalid arguments: title must be a non-empty string"))))
(-> (logged-in-todos)
(.then (fn [_] (in-order create-one todos)))
(.then (constantly nil))))
(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. Resolves to nil (\"ok\"): the checkboxes show it, and the next request's state has it too."
[{:keys [todos]}]
(check-todos! todos (fn [{:keys [id done]}]
(check-id! id)
(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)]
(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)))
(.then (constantly nil))))
(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)
(change-todos [::events/delete-todo id]
#(nil? (find-todo (get-in % [:todos :items]) id))
"the todo to go")))
(.then (fn [_] "deleted"))))
;; Tic-tac-toe is moves taken in turns: X, then O, on the same board. The agent can move for
;; either side, so every result says whose turn it is.
"Presses the Delete button of several todos. Every id is looked up before the first is deleted.
Resolves to nil (\"ok\"): they're gone from the page, and from the next request's state."
[{:keys [todos]}]
(check-todos! todos #(check-id! (:id %)))
(let [ids (distinct (map :id todos))]
(-> (logged-in-todos)
(.then (fn [items]
(run! #(find-todo! items %) ids)
(show! :todos)
(in-order delete-one ids)))
(.then (constantly nil)))))
(defn- tic-tac-toe-state
"The game as the page shows it: the 9 cells (row by row, cell 0 is the top left; null when
@@ -193,107 +281,194 @@
(defn- get-tic-tac-toe [_]
(tic-tac-toe-state))
;; --- State (tbd.ui.model-context/current-state, attached to every request of the page's own
;; chatbot instead of spent as a read tool's call; see tbd.ui.model-context's docstring) ---
(defn- todos-state
"The todos, once they have loaded: nil (nothing to add to the state) while they haven't, or
there is no login, rather than an empty list that would read as \"there are none\"."
[]
(let [{:keys [status items]} (:todos (db))]
(when (= :ok status)
{:todos (mapv #(select-keys % [:id :title :done]) items)})))
(def state-providers
"{:pages :provide}, one per page that has state worth telling the model up front. `provide`
returns the page's state as a map, or nil for nothing to add right now (see
tbd.ui.model-context/current-state, which merges them)."
[{:pages #{:todos} :provide todos-state}
{:pages #{:tic-tac-toe} :provide tic-tac-toe-state}
{:pages #{:calculator} :provide (fn [] (:calc (db)))}])
(defn- move-tic-tac-toe
"Presses cell `cell`, which moves for whoever's turn it is. With `player`, only if it is that
player's turn: a guard against moving for the wrong side."
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn. Returns the
board afterwards (the same shape as get_tic_tac_toe), so the result itself says what changed."
[{:keys [cell player]}]
(when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 8))
(fail! "invalid arguments: cell must be an integer from 0 to 8"))
(when-not (contains? #{nil "x" "o"} player)
(when-not (contains? #{"x" "o"} player)
(fail! "invalid arguments: player must be \"x\" or \"o\""))
(let [{:keys [board turn]} (:ttt (db))]
(when (tictactoe/outcome board)
(fail! "the game is over: start a new game"))
(when (and player (not= player (name turn)))
(fail! (str "it is " (name turn) "'s turn, not " player "'s")))
(fail! "the game is over: the person starts a new one, with the page's own New game button"))
(when (not= player (name turn))
(fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move")))
(when (board cell)
(fail! (str "cell " cell " is taken")))
(show! :tic-tac-toe)
(rf/dispatch-sync [::events/ttt-move cell])
(tic-tac-toe-state)))
(defn- new-tic-tac-toe-game
"Presses New game."
[_]
(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}."
[{:name "ping" :description "Health check: returns pong"
"The tools, as {:name :description :input-schema :handler :pages}. `pages` is where the page's
own chatbot is offered the tool (see tbd.ui.model-context): the tools of a page's content are
only offered on that page, and the rest (no `pages`) on every page. An agent outside the page,
through WebMCP, is offered all of them."
[{:name "ping" :description "Health check: returns pong. Almost never useful: do not call it to look busy"
:input-schema (object-schema {} []) :handler ping}
{:name "whoami"
:description "Says who is logged in on this page, if anyone"
:input-schema (object-schema {} []) :handler whoami}
{:name "get_calculator"
{:name "navigate"
:description (str "Opens one of the pages of the app, as a click on its tab would. It only moves you "
"there: it does not read what the page holds, so it is not a way to check or refresh "
"anything. The pages are: "
(str/join ", " (map (fn [{:keys [id title login?]}]
(str (name id) " (" title (when login? ", needs a login") ")"))
pages/pages))
". Each page has tools of its own, which are on offer once you are on it. Go there "
"yourself, without asking, whenever what the user wants is on another page")
:input-schema (object-schema {:page {:type "string" :enum (mapv (comp name :id) pages/pages)
:description "The page to open"}}
["page"])
:handler navigate}
{:name "get_calculator" :pages #{:calculator} :read-only? true
:description (str "What the calculator form on this page holds (JSON): the x and y in its fields, and "
"the result it is showing (status idle, loading, ok with the sum, or error with the message)")
:input-schema (object-schema {} []) :handler get-calculator}
{:name "add"
:description "Types two numbers into the calculator form, presses Add, and returns the sum the page shows (JSON)"
{: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"}
:y {:type "number" :description "The second number"}}
["x" "y"])
:handler add}
{:name "list_todos"
{:name "list_todos" :pages #{:todos} :read-only? true
:description (str "Lists the todos this page shows (JSON: id, title, done, created-at, updated-at), oldest first. "
"Needs a login on the page")
:input-schema (object-schema {} []) :handler list-todos}
{:name "get_todo"
:description "Gets one of the todos this page shows, by id (JSON)"
:input-schema (object-schema {:id todo-id} ["id"]) :handler get-todo}
{:name "get_todo" :pages #{:todos} :read-only? true
:description (str "Gets todos this page shows, by id (JSON list). Takes a list: to read several, make ONE call "
"with all of them")
:input-schema (todos-schema "The todos to get, one per todo" {:id todo-id} ["id"])
:handler get-todo}
{:name "create_todo"
: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"])
{:name "create_todo" :pages #{:todos}
:description (str "Adds todos: types each title into the new-todo field and presses Add. Takes a list: to add "
"several, make ONE call with all of them, never one call per todo")
:input-schema (todos-schema "The todos to add, one per todo"
{:title {:type "string" :minLength 1 :maxLength 200 :description "What needs doing"}}
["title"])
:handler create-todo}
{:name "set_todo_done"
: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"])
{:name "set_todo_done" :pages #{:todos}
:description (str "Ticks or unticks the checkboxes of todos. Takes a list: to change several, make ONE call "
"with all of them, never one call per todo")
:input-schema (todos-schema "The changes to make, one per todo"
{:id todo-id
:done {:type "boolean" :description "true to tick it off, false to untick it"}}
["id" "done"])
:handler set-todo-done}
{:name "delete_todo"
:description "Presses a todo's Delete button"
:input-schema (object-schema {:id todo-id} ["id"])
{:name "delete_todo" :pages #{:todos}
:description (str "Deletes todos for good, by pressing their Delete buttons. Find the id first — from the "
"page's current state if you have it, or list_todos — never guess one, and never delete a "
"todo the user did not clearly point at. Takes a list: to delete several, make ONE call "
"with all of them")
:input-schema (todos-schema "The todos to delete, one per todo" {:id todo-id} ["id"])
:handler delete-todo}
{:name "get_tic_tac_toe"
{:name "get_tic_tac_toe" :pages #{:tic-tac-toe} :read-only? true
:description (str "The tic-tac-toe game on this page (JSON): board (9 cells, row by row, cell 0 the top left "
"and cell 8 the bottom right; null when empty, else \"x\" or \"o\"), turn (whose move it "
"is, \"x\" or \"o\": X goes first, and they alternate) and status (in_progress, won or draw; "
"when won, also winner and line). A person moves on the same board, so check the turn "
"before you move")
"when won, also winner and line)")
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
{:name "move_tic_tac_toe"
:description (str "Presses a cell of the tic-tac-toe board, which moves for whoever's turn it is, and returns "
"the game as get_tic_tac_toe does (including whose turn is next). Fails if the cell is "
"taken or the game is over")
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe} :once-per-turn? true
:description (str "Presses a cell of the tic-tac-toe board as `player`, and returns the board afterwards "
"(JSON, the same shape as get_tic_tac_toe). Fails, and changes nothing, if it isn't that "
"side's turn yet, the cell is taken or the game is over. Runs at most once per message: "
"asked for a move, make the one call and answer with a short line, a board sketch if that "
"helps — a second call this turn is refused, unasked")
:input-schema (object-schema {:cell {:type "integer" :minimum 0 :maximum 8
:description "0 is the top left, 2 the top right, 8 the bottom right"}
:player {:type "string" :enum ["x" "o"]
:description (str "Optional: the side you are moving for. The move is "
"refused if it is the other side's turn")}}
["cell"])
:handler move-tic-tac-toe}
:description "Which side this move is for"}}
["cell" "player"])
:handler move-tic-tac-toe}])
{:name "new_tic_tac_toe_game"
: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"
:handler (fn [_] prompt/tic-tac-toe)}])
(defn- page-state
"A promise of what the page is showing: the open page, the pages and who is logged in."
[]
(-> (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 ---
@@ -305,21 +480,13 @@
#js {"content" content "isError" true}
#js {"content" content})))
(defn- ->text [value]
(cond
(string? value) value
(nil? value) "ok"
:else (js/JSON.stringify (clj->js value))))
(defn- execute
"A WebMCP `execute` callback for `handler`: runs it on the arguments, and turns what it
returns, or the error it throws, into a tool result."
[handler]
(fn [args]
(-> (js/Promise.resolve)
(.then #(handler (js->clj args :keywordize-keys true)))
(.then (fn [value] (text-result (->text value) false)))
(.catch (fn [e] (text-result (or (some-> e (aget "message")) (str e)) true))))))
(-> (model-context/run handler (js->clj args :keywordize-keys true))
(.then (fn [{:keys [text error?]}] (text-result text error?))))))
(defn register-tools!
"Registers `tools` on `mcp`, a WebMCP instance: `registerTool(name, description, inputSchema,
@@ -330,11 +497,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!))
+66
View File
@@ -0,0 +1,66 @@
// Preloaded by `npm test` (node -r) before any compiled code runs: gives the ClojureScript
// tests a browser-like global scope (window, document, location, ...) backed by jsdom.
//
// It has to happen first: React DOM decides at load time whether the browser supports the
// `input` event; without a `window` then, <input onChange> never fires under test.
const { JSDOM } = require("jsdom");
const { window } = new JSDOM('<!doctype html><html><body><div id="app"></div></body></html>', {
url: "http://localhost:3000/",
});
// Copy the window's globals over, but leave Node's own (fetch, setTimeout, navigator, ...) alone.
for (const key of Object.getOwnPropertyNames(window)) {
if (!(key in globalThis)) {
Object.defineProperty(globalThis, key, {
configurable: true,
get: () => window[key],
set: (value) => Object.defineProperty(globalThis, key, { value, writable: true, configurable: true }),
});
}
}
globalThis.window = window;
// WebMCP, for `require("@jason.today/webmcp/src/webmcp.js")`. Its only export is
// `module.exports = WebMCP`, guarded by `typeof module`, in a file its package.json declares as an
// ES module. The browser build wraps it as CommonJS, so there it exports the class; Node's
// require() loads it as ESM, where `module` doesn't exist, and gets nothing. So run the same
// source with a `module` to export to, and hand that to require.
const Module = require("module");
const fs = require("fs");
const webmcp = require.resolve("@jason.today/webmcp/src/webmcp.js");
const cjs = new Module(webmcp);
cjs.filename = webmcp;
new Function("module", "exports", fs.readFileSync(webmcp, "utf8"))(cjs, cjs.exports);
cjs.loaded = true;
require.cache[webmcp] = cjs;
// A run that doesn't finish must not look like a pass. An async test that throws before it calls
// `done` (or whose promise chain rejects) never ends: the process then hangs, or runs out of things
// to do and exits 0 without a word. Fail instead, and say which test it was.
function fail(message) {
console.error(`\nFAILED: ${message}`);
process.exit(1);
}
process.on("unhandledRejection", (reason) =>
fail(`unhandled promise rejection (an async test without a catch?): ${(reason && reason.stack) || reason}`));
// tbd.ui.test-util keeps `uiTestsCurrent` up to date: the test that is running, and since when.
const STUCK_MS = 30000;
globalThis.uiTestsCurrent = { name: "loading the tests", since: Date.now() };
setInterval(() => {
const { name, since } = globalThis.uiTestsCurrent;
if (Date.now() - since > STUCK_MS) {
fail(`stuck for ${STUCK_MS / 1000}s in ${name} (an async test that never called done?)`);
}
}, 1000).unref();
// ... and sets `uiTestsFinished` once cljs.test has printed its summary.
process.on("exit", (code) => {
if (code === 0 && !globalThis.uiTestsFinished) {
console.error("\nFAILED: the tests ended without reporting a result");
process.exitCode = 1;
}
});
+76
View File
@@ -0,0 +1,76 @@
(ns tbd.ui.core-test
(:require [cljs.test :refer [deftest is async use-fixtures]]
[re-frame.db :as rf-db]
[reagent.dom.client :as rdc]
[tbd.ui.core :as core]
[tbd.ui.model-context :as model-context]
[tbd.ui.test-util :as tu]
[tbd.ui.webmcp :as webmcp]))
;; init runs as in the browser, WebMCP widget included (the library is loaded through
;; test/webmcp-shim.cjs; see shadow-cljs.edn). Each test gets a fresh widget, and it is taken
;; off the page afterwards.
(defn- widget [] @@#'webmcp/widget)
(defn- tools-in-widget
"The names of the tools the WebMCP widget offers its client."
[]
(set (js/Array.from (.keys (.-availableTools ^js (widget))))))
(def ^:private real-log (.-log js/console))
(use-fixtures :each
tu/fake-server-fixture
tu/url-fixture
{:before (fn []
(reset! @#'webmcp/widget nil)
;; The widget logs every tool it registers. (Not console.log as a whole: that is
;; where the test report goes.)
(set! (.-log js/console)
(fn [& args]
(when-not (re-find #"^(Tool registered|Saved items)" (str (first args)))
(.apply real-log js/console (to-array args))))))
:after (fn []
(set! (.-log js/console) real-log)
(when-let [w (widget)]
(some-> (.getElementById js/document (.-elementId ^js w)) .remove))
(reset! @#'webmcp/widget nil)
(.clear js/sessionStorage)
(model-context/clear!)
;; init mounts the page in a root of its own.
(when-let [root @core/root]
(rdc/unmount root)
(reset! core/root nil)))})
(deftest init-test
(tu/log-in!)
(async done
(tu/finish
(tu/steps
(fn []
(core/init)
(is (= :unknown (get-in @rf-db/app-db [:user :status])) "it starts out not knowing who is logged in")
(tu/shows "the page is on the screen" "main h1" "tbd"))
(fn []
(is (some? (.getElementById js/document (.-elementId ^js (widget)))) "the WebMCP widget is on the page")
(is (= (set (map :name webmcp/tools)) (tools-in-widget)) "it offers the page's tools to the agent")
(is (= (map :name (remove :pages webmcp/tools)) (map :name (model-context/definitions :ai-setup)))
"and to the chatbot, the ones of the page it is on")
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn :x}
(model-context/current-state :tic-tac-toe))
"and its state, for the page it starts on")
;; A tool, as the agent's client calls it.
(let [ping (.-execute (.get (.-availableTools ^js (widget)) "ping"))]
(-> (ping #js {})
(.then (fn [result] (is (= "pong" (.. result -content (at 0) -text))))))))
(fn []
(tu/eventually (fn [] (some #(= "Todos" (.-textContent %)) (tu/q-all "nav a")))))
(fn []
(is (= :logged-in (get-in @rf-db/app-db [:user :status])))
;; The hot-reload hook redraws and registers the tools again, without starting over.
(.clear (.-availableTools ^js (widget)))
(core/reload)
(is (= (set (map :name webmcp/tools)) (tools-in-widget)))
(tu/shows "still there after a reload" "main h1" "tbd")))
done)))
File diff suppressed because it is too large Load Diff
+182
View File
@@ -0,0 +1,182 @@
(ns tbd.ui.fetch-stream-test
"The ::fetch-stream effect (what the chat's replies come in through), run for real against fakes
of fetch that fail in the ways a network does."
(:require [cljs.test :refer [deftest is testing async use-fixtures]]
[re-frame.core :as rf]
[tbd.ui.events :as events]
[tbd.ui.test-util :as tu]))
(use-fixtures :each tu/fake-server-fixture)
(def ^:private got (atom []))
(rf/reg-event-fx ::got-event (fn [_ [_ event]] (swap! got conj [:event event]) nil))
(rf/reg-event-fx ::got-response (fn [_ [_ response]] (swap! got conj [:response response]) nil))
(defn- bytes-of [text] (.encode (js/TextEncoder.) text))
(defn- reader
"A body reader that gives `reads` one at a time: bytes, or :fail for a read that fails. Then it's done."
[reads]
(let [reads (atom reads)]
#js {:read (fn []
(let [r (first @reads)]
(swap! reads rest)
(cond
(nil? r) (js/Promise.resolve #js {:done true})
(= :fail r) (js/Promise.reject (js/Error. "network error"))
:else (js/Promise.resolve #js {:done false :value r}))))}))
(defn- streaming
"A fetch that answers 200 with a body of `reads` (see `reader`), and notes what it was asked."
[asked & reads]
(fn [uri opts]
(reset! asked [uri (js->clj opts :keywordize-keys true)])
(js/Promise.resolve #js {:ok true :status 200 :body #js {:getReader (fn [] (reader reads))}})))
(defn- stream!
"Runs the effect against `fetch`, and gives a promise of what was dispatched once `n` things were
(and a moment more, for anything that shouldn't come)."
[fetch n]
(reset! got [])
(aset js/globalThis "fetch" fetch)
((tu/real-effect ::events/fetch-stream)
{:uri "/api/chat" :method "POST" :body {:x 1} :on-event [::got-event] :on-response [::got-response]})
(-> (tu/eventually #(>= (count @got) n))
(.then (fn [_] (js/Promise. (fn [resolve] (js/setTimeout #(resolve @got) 30)))))))
(defn- sse [& events]
(bytes-of (apply str (map #(str "data: " (js/JSON.stringify (clj->js %)) "\n\n") events))))
(deftest request-test
(async done
(let [asked (atom nil)]
(tu/finish
(tu/steps
#(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1)
(fn [_]
(let [[uri opts] @asked]
(is (= ["/api/chat" {:method "POST"
:headers {:Content-Type "application/edn"}
:body "{:x 1}"}]
[uri (dissoc opts :signal)]))
(is (instance? js/AbortSignal (:signal opts)) "with a signal, for ::abort-stream"))))
done))))
(deftest abort-test
;; Halted (see ::events/chat-halt): nothing more is dispatched — not the rest of the stream, nor
;; the \"connection lost\" its end would otherwise be.
(async done
(let [release (atom nil)
fetch (fn [_ _]
(js/Promise.resolve
#js {:ok true :status 200
:body #js {:getReader
(fn []
(let [reads (atom [(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :wait])]
#js {:read (fn []
(let [r (first @reads)]
(swap! reads rest)
(cond
(= :wait r) (js/Promise. #(reset! release %))
(nil? r) (js/Promise.resolve #js {:done true})
:else (js/Promise.resolve #js {:done false :value r}))))
:cancel (fn [] (js/Promise.resolve nil))}))}}))]
(tu/finish
(tu/steps
#(stream! fetch 1)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] got))
((tu/real-effect ::events/abort-stream) true)
(@release #js {:done false :value (sse {:type "TEXT_MESSAGE_CONTENT" :delta "late"})})
(js/Promise. (fn [resolve] (js/setTimeout resolve 30))))
(fn [_]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] @got) "nothing after the abort")))
done))))
(deftest events-test
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil)
(sse {:type "REASONING_MESSAGE_CONTENT" :delta "hm"} {:type "TEXT_MESSAGE_CONTENT" :delta "Hel"})
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "lo"} {:type "RUN_FINISHED"}))
4)
(fn [got]
(is (= [[:event {:type "REASONING_MESSAGE_CONTENT" :delta "hm"}]
[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hel"}]
[:event {:type "TEXT_MESSAGE_CONTENT" :delta "lo"}]
[:event {:type "RUN_FINISHED"}]]
got)
"each event as it arrives, and nothing more when it ended properly")))
done)))
(deftest split-anywhere-test
;; The network cuts the stream wherever it likes: in a line, and in a multi-byte character too.
(async done
(let [bytes (sse {:type "TEXT_MESSAGE_CONTENT" :delta "héllo 👋 世界"} {:type "RUN_FINISHED"})
expected [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "héllo 👋 世界"}] [:event {:type "RUN_FINISHED"}]]]
(tu/finish
(apply tu/steps
(for [cut (range 1 (.-length bytes))]
(fn [_]
(-> (stream! (streaming (atom nil) (.subarray bytes 0 cut) (.subarray bytes cut)) 2)
(.then (fn [got] (is (= expected got) (str "cut at byte " cut))))))))
done))))
(deftest lost-connection-test
(testing "a stream that ends without saying it is over"
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"})) 2)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the connection was lost"}]]
got))))
done)))
(testing "a read that fails in the middle of the stream"
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :fail
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "never"}))
2)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the connection was lost"}]]
got))))
done)))
(testing "a stream that ended with an error of its own says so once"
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil)
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}
{:type "RUN_ERROR" :message "the LLM server took too long to answer"}))
2)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the LLM server took too long to answer"}]]
got))))
done))))
(deftest failed-request-test
(testing "a status that isn't 2xx: no stream, the response is given as ::fetch gives it"
(async done
(tu/finish
(tu/steps
#(stream! (fn [_ _] (js/Promise.resolve #js {:ok false :status 502
:text (fn [] (js/Promise.resolve "{:error \"down\"}"))}))
1)
(fn [got]
(is (= [[:response {:ok? false :status 502 :body "{:error \"down\"}"}]] got))))
done)))
(testing "a request that fails outright"
(async done
(tu/finish
(tu/steps
#(stream! (fn [_ _] (js/Promise.reject (js/Error. "Failed to fetch"))) 1)
(fn [got]
(is (= [[:response {:ok? false :status nil :body "Failed to fetch"}]] got))))
done))))
+34
View File
@@ -0,0 +1,34 @@
(ns tbd.ui.markdown-test
(:require [cljs.test :refer [deftest is testing]]
[tbd.ui.markdown :as markdown]))
(deftest render-test
(testing "plain text, wrapped in a paragraph"
(is (= [:<> [:p "hello"]] (markdown/render "hello"))))
(testing "inline formatting"
(is (= [:<> [:p "a " [:strong "bold"] " " [:em "word"] " and " [:code "code"]]]
(markdown/render "a **bold** *word* and `code`"))))
(testing "a single newline is a line break, not a new paragraph"
(is (= [:<> [:p "one" [:br] "two"]] (markdown/render "one\ntwo"))))
(testing "a stray * or _ that isn't emphasis (padded with a space) is left alone"
(is (= [:<> [:p "3 * 4 * 5"]] (markdown/render "3 * 4 * 5"))))
(testing "headings, a list, a fenced code block"
(is (= [:<>
[:h1 "Title"]
[:ul [:li "a"] [:li "b"]]
[:pre [:code {:class "language-js"} "1"]]]
(markdown/render "# Title\n\n- a\n- b\n\n```js\n1\n```"))))
(testing "an ordered list and a blockquote"
(is (= [:<> [:ol [:li "a"] [:li "b"]]] (markdown/render "1. a\n2. b")))
(is (= [:<> [:blockquote [:p "hi"]]] (markdown/render "> hi"))))
(testing "a table"
(is (= [:<> [:table [:thead [:tr [:th "a"] [:th "b"]]]
[:tbody [:tr [:td "1"] [:td "2"]]]]]
(markdown/render "a | b\n-|-\n1 | 2"))))
(testing "no markup leaks through as HTML: it's always a plain string, never dangerouslySetInnerHTML"
(is (= [:<> [:p "hi<script>alert(1)</script>"]] (markdown/render "hi<script>alert(1)</script>"))))
(testing "a link opens in its own tab, not the app's"
(is (= [:<> [:p [:a {:href "https://example.com" :target "_blank" :rel "noopener noreferrer"} "x"]]]
(markdown/render "[x](https://example.com)"))))
(testing "a javascript: link loses its href (and so its target/rel), the text stays"
(is (= [:<> [:p [:span "x"]]] (markdown/render "[x](javascript:evil)")))))
+160
View File
@@ -0,0 +1,160 @@
(ns tbd.ui.model-context-test
(:require [cljs.test :refer [deftest is testing async use-fixtures]]
[tbd.ui.model-context :as model-context]
[tbd.ui.test-util :as tu]))
(use-fixtures :each
{:before model-context/clear!
:after model-context/clear!})
(def ^:private schema {:type "object" :properties {} :required []})
(defn- tool [tool-name handler & {:as more}]
(merge {:name tool-name :description (str tool-name " tool") :input-schema schema :handler handler} more))
(deftest definitions-test
(testing "nothing registered, nothing offered"
(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 :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 :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 :tic-tac-toe)))))
(testing "tools of other names stay"
(model-context/register! [(tool "c" identity)])
(is (= ["a" "b" "c"] (map :name (model-context/definitions :tic-tac-toe)))))
(testing "clear! takes them all"
(model-context/clear!)
(is (= [] (model-context/definitions :tic-tac-toe)))))
(deftest pages-test
(model-context/register! [(tool "everywhere" identity)
(tool "tic-tac-toe-only" identity :pages #{:tic-tac-toe})
(tool "todos-only" identity :pages #{: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" "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 :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 "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! :tic-tac-toe tool-name arguments))
(deftest call-test
(let [seen (atom nil)]
(model-context/register!
[(tool "echo" (fn [args] (reset! seen args) (str "got " (pr-str args))))
(tool "data" (fn [_] {:a 1 :b [true nil]}))
(tool "nothing" (fn [_] nil))
(tool "later" (fn [_] (js/Promise.resolve "eventually")))
(tool "throws" (fn [_] (throw (js/Error. "boom"))))
(tool "rejects" (fn [_] (js/Promise.reject (js/Error. "no luck"))))
(tool "rejects-plainly" (fn [_] (js/Promise.reject "just a string")))])
(async done
(tu/finish
(tu/steps
#(called "echo" "{\"x\":1,\"name\":\"a b\",\"nested\":{\"y\":[1,2]}}")
(fn [r]
(testing "the arguments the LLM wrote reach the tool as a map with keyword keys"
(is (= {:x 1 :name "a b" :nested {:y [1 2]}} @seen))
(is (= {:text "got {:x 1, :name \"a b\", :nested {:y [1 2]}}" :error? false} r))))
#(called "echo" "")
(fn [r]
(testing "no arguments at all is an empty map: that is how a model calls a tool that takes none"
(is (= {} @seen))
(is (false? (:error? r)))))
#(called "echo" " ")
(fn [_] (is (= {} @seen) "blank too"))
#(called "echo" "{}")
(fn [_] (is (= {} @seen)))
#(called "data" "{}")
(fn [r]
(testing "data becomes JSON"
(is (= {:text "{\"a\":1,\"b\":[true,null]}" :error? false} r))))
#(called "nothing" "{}")
(fn [r] (is (= {:text "ok" :error? false} r) "a tool with nothing to say says ok"))
#(called "later" "{}")
(fn [r] (is (= {:text "eventually" :error? false} r) "a promise is waited for"))
#(called "throws" "{}")
(fn [r] (is (= {:text "boom" :error? true} r) "a tool that fails is an error result, not a failure"))
#(called "rejects" "{}")
(fn [r] (is (= {:text "no luck" :error? true} r)))
#(called "rejects-plainly" "{}")
(fn [r] (is (= {:text "just a string" :error? true} r))))
done))))
(deftest call-pages-test
(let [ran (atom [])]
(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! :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 "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: tic-tac-toe-only (it is offered on the tic-tac-toe page)"
:error? true}
r))))
(fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run")))
done))))
(deftest current-state-test
(testing "nothing registered, nothing to offer"
(is (= {} (model-context/current-state :todos))))
(model-context/register-state! [{:provide (fn [] {:todos [{:title "milk"}]}) :pages #{:todos}}
{:provide (fn [] {:board (vec (repeat 9 nil))}) :pages #{:tic-tac-toe}}
{:provide (fn [] {:page-status "ok"})}])
(testing "only the providers offered on the page run, merged into one map"
(is (= {:todos [{:title "milk"}] :page-status "ok"} (model-context/current-state :todos)))
(is (= {:board (vec (repeat 9 nil)) :page-status "ok"} (model-context/current-state :tic-tac-toe)))
(is (= {:page-status "ok"} (model-context/current-state :calculator))))
(testing "clear! takes state providers away too"
(model-context/clear!)
(is (= {} (model-context/current-state :todos)))))
(deftest call-failures-test
(let [ran? (atom false)]
(model-context/register! [(tool "t" (fn [_] (reset! ran? true) "ran"))])
(async done
(tu/finish
(tu/steps
#(called "nope" "{}")
(fn [r]
(testing "a tool that isn't there: the LLM may have made it up, and reads what it got wrong"
(is (= {:text "unknown tool: nope" :error? true} r))))
#(called "t" "{not json")
(fn [r]
(testing "arguments that are no JSON"
(is (= {:text "invalid arguments: they must be a JSON object" :error? true} r))))
#(called "t" "[1,2]")
(fn [r] (is (:error? r) "an array isn't arguments"))
#(called "t" "\"text\"")
(fn [r] (is (:error? r) "nor is a string"))
#(called "t" "null")
(fn [r] (is (:error? r) "nor is null"))
(fn [_] (is (false? @ran?) "the tool was never called with any of them")))
done))))
+26
View File
@@ -0,0 +1,26 @@
(ns tbd.ui.pages-test
(:require [cljs.test :refer [deftest is testing]]
[tbd.ui.pages :as pages]))
(deftest page->hash-test
(is (= "#/tic-tac-toe" (pages/page->hash :tic-tac-toe)))
(is (= "#/ai-setup" (pages/page->hash :ai-setup))))
(deftest hash->page-test
(testing "every page has an address that opens it"
(doseq [{:keys [id]} pages/pages]
(is (= id (pages/hash->page (pages/page->hash id))))))
(testing "with or without the #"
(is (= :todos (pages/hash->page "#/todos")))
(is (= :todos (pages/hash->page "/todos")))
(is (= :todos (pages/hash->page "todos"))))
(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 (= :tic-tac-toe pages/default-page))
(doseq [hash [nil "" "#" "#/" "#/nowhere" "#/Todos"]]
(is (= :tic-tac-toe (pages/hash->page hash)) (pr-str hash)))))
(deftest pages-test
(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)))))
+31
View File
@@ -0,0 +1,31 @@
(ns tbd.ui.sse-test
(:require [cljs.test :refer [deftest is testing]]
[tbd.ui.sse :as sse]))
(deftest parse-test
(testing "complete events come out as maps, in order"
(is (= [[{:content "Hel"} {:content "lo"} {:done true}] ""]
(sse/parse "data: {\"content\":\"Hel\"}\n\ndata: {\"content\":\"lo\"}\n\ndata: {\"done\":true}\n\n"))))
(testing "an event that hasn't fully arrived is given back, to be put in front of the next piece"
(is (= [[{:content "a"}] "data: {\"content\":\"b"]
(sse/parse "data: {\"content\":\"a\"}\n\ndata: {\"content\":\"b")))
(is (= [[] "data: {\"content\":\"a\"}\n"]
(sse/parse "data: {\"content\":\"a\"}\n")) "the blank line that ends it hasn't come")
(is (= [[] ""] (sse/parse ""))))
(testing "pieces cut anywhere give the same events"
(let [text "data: {\"thinking\":\"hm\"}\n\ndata: {\"content\":\"h\\u00e9llo\\n\"}\n\ndata: {\"done\":true}\n\n"
expected [{:thinking "hm"} {:content "héllo\n"} {:done true}]]
(doseq [cut (range (inc (count text)))]
(let [[first-events pending] (sse/parse (subs text 0 cut))
[more-events pending] (sse/parse (str pending (subs text cut)))]
(is (= expected (into first-events more-events)) (str "cut at " cut))
(is (= "" pending))))))
(testing "a space after `data:` is optional, and a line break can be CRLF"
(is (= [[{:content "a"} {:content "b"}] ""]
(sse/parse "data:{\"content\":\"a\"}\r\n\r\ndata: {\"content\":\"b\"}\r\n\r\n"))))
(testing "events that carry no data, or no JSON, are skipped"
(is (= [[{:content "a"}] ""]
(sse/parse ": keep-alive\n\nevent: ping\n\ndata: not json\n\ndata: {\"content\":\"a\"}\n\n"))))
(testing "data over several lines is one JSON text"
(is (= [[{:content "a"}] ""]
(sse/parse "data: {\"content\":\ndata: \"a\"}\n\n")))))
+58
View File
@@ -0,0 +1,58 @@
(ns tbd.ui.subs-test
(:require [cljs.test :refer [deftest is testing use-fixtures]]
[re-frame.core :as rf]
[re-frame.db :as rf-db]
[re-frame.subs :as rf-subs]
[tbd.ui.db :as db]
[tbd.ui.subs :as subs]
[tbd.ui.tictactoe :as ttt]))
(use-fixtures :each
{:before #(do (rf/clear-subscription-cache!)
(reset! rf-db/app-db db/default-db))})
(defn- sub
"The value of a subscription. (Read outside of a component, which re-frame warns about.)"
[query]
(with-redefs [rf-subs/warn-when-not-reactive (fn [])]
@(rf/subscribe query)))
(defn- db! [f & args]
(apply swap! rf-db/app-db f args))
(deftest plain-subs-test
(testing "a new page"
(is (= "" (sub [::subs/operand :x])))
(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])))
(is (false? (sub [::subs/mcp-copied?]))))
(testing "they follow the db"
(db! assoc :page :todos)
(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 "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 "a1" :title "a"}] (:items (sub [::subs/todos]))))
(is (true? (sub [::subs/mcp-copied?])))))
(deftest ttt-game-test
(let [set-board! (fn [cells turn] (db! assoc :ttt {:board (mapv {\x :x \o :o} cells) :turn turn}))]
(testing "a new game: X to move, nobody has won"
(is (= {:board ttt/new-board :turn :x :outcome nil} (sub [::subs/ttt-game]))))
(testing "in progress"
(set-board! "x...o...." :x)
(is (= {:board [:x nil nil nil :o nil nil nil nil] :turn :x :outcome nil}
(sub [::subs/ttt-game]))))
(testing "a win, with the line"
(set-board! "xxxoo...." :o)
(is (= {:player :x :line [0 1 2]} (:outcome (sub [::subs/ttt-game])))))
(testing "a draw"
(set-board! "xoxxoooxx" :o)
(is (= :draw (:outcome (sub [::subs/ttt-game])))))))
+326
View File
@@ -0,0 +1,326 @@
(ns tbd.ui.test-util
"Shared fakes for the UI tests: the server the page talks to (a stand-in for `fetch`), a way
to stub re-frame effects, and helpers to drive the page in jsdom (see dom-setup.cjs)."
(:require [cljs.reader :as reader]
[cljs.test :as t :refer [is]]
[re-frame.registrar :as registrar]
[reagent.dom.client :as rdc]))
;; --- Telling dom-setup.cjs how the run is going (it fails a run that gets stuck or ends early) ---
(let [begin (get-method t/report [::t/default :begin-test-var])]
(defmethod t/report [::t/default :begin-test-var] [m]
(when begin (begin m))
(set! (.-uiTestsCurrent js/globalThis)
#js {:name (str (:name (meta (:var m)))) :since (js/Date.now)})))
(let [summary (get-method t/report [::t/default :summary])]
(defmethod t/report [::t/default :summary] [m]
(summary m)
(set! (.-uiTestsFinished js/globalThis) true)))
;; --- A fake server ---
(def server
"What the fake server holds: {:user nil-or-{:login ..}, :todos [..], :next-id n, :add-error msg,
:chat-error msg, :chats [the conversations it was sent], :chat-requests [the whole requests],
:chat-scripts [..], :chat-script [..], :resume fn}. Its LLM says \"echo: \" and the last message,
streaming it in pieces. `:chat-script`, if set, is what it streams instead: events (maps, as the
real server sends them) and :pause, where the stream stops until the test calls the `:resume` fn
the server then holds. `:chat-scripts` are scripts for the next requests, one each, first
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)})
(defn- respond-stream
"A 200 whose body is the server-sent events of `script` (events and :pause)."
[script]
{:status 200 :script script})
(defn- next-chat-script!
"The next of the server's `:chat-scripts`, which it is then rid of, or nil."
[]
(when-let [script (first (:chat-scripts @server))]
(swap! server update :chat-scripts subvec 1)
script))
(defn- route [method uri body]
(let [{:keys [user todos]} @server
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)
(respond 200 {:logged-out true}))
(and (= "GET" method) (re-find #"^/api/add\?" uri))
(let [[_ x y] (re-find #"x=([^&]*)&y=([^&]*)" uri)]
(if-let [error (:add-error @server)]
(respond 400 {:error error :details {:x ["is wrong"]}})
(respond 200 {:result (+ (js/parseFloat x) (js/parseFloat y))})))
(not user) (respond 401 {:error "not logged in"})
(and (= "POST" method) (= "/api/chat" uri))
(if-let [error (:chat-error @server)]
(respond 502 {:error error})
(do (swap! server update :chats (fnil conj []) (:messages body))
(swap! server update :chat-requests (fnil conj []) body)
(respond-stream (or (next-chat-script!)
(:chat-script @server)
[{:thinking "Reading the message."}
{:content "echo: "}
{:content (:content (last (:messages body)))}
{:done true}]))))
(and (= "GET" method) (= "/api/chat/history" uri)) (respond 200 {:messages (:chat-history @server [])})
(and (= "PUT" method) (= "/api/chat/history" uri))
(do (swap! server assoc :chat-history (:messages body))
(respond 200 {:saved true}))
(and (= "DELETE" method) (= "/api/chat/history" uri))
(do (swap! server assoc :chat-history [])
(respond 200 {:cleared true}))
(and (= "GET" method) (= "/api/todos" uri)) (respond 200 {:todos todos})
(and (= "POST" method) (= "/api/todos" uri))
(if (seq (.trim (:title body)))
(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))
(respond 400 {:error "Invalid body" :details {:title ["must not be blank"]}}))
(and (= "PATCH" method) todo-id)
(if-let [todo (first (filter #(= todo-id (:id %)) todos))]
(let [changed (merge todo body)]
(swap! server update :todos (fn [ts] (mapv #(if (= todo-id (:id %)) changed %) ts)))
(respond 200 changed))
(respond 404 {:error "todo not found"}))
(and (= "DELETE" method) todo-id)
(do (swap! server update :todos (fn [ts] (filterv #(not= todo-id (:id %)) ts)))
(respond 200 {:deleted true}))
:else (respond 404 {:error "not found"}))))
(def ^:private piece-size
"How many bytes of a stream the fake server delivers at a time: few, so events are cut anywhere,
even in the middle of a character, as the network may."
7)
(defn- text? [x] (and (string? x) (seq x)))
(defn- tool-call-events [{:keys [id name arguments]}]
[{:type "TOOL_CALL_START" :toolCallId id :toolCallName name}
{:type "TOOL_CALL_ARGS" :toolCallId id :delta arguments}
{:type "TOOL_CALL_END" :toolCallId id}])
(defn- old->agui
"A script step, in the old shape tests write ({:thinking}/{:content}/{:tool-calls}/{:done}/
{:error}) as the AG-UI events (see tbd.chat.routes) it now corresponds to."
[{:keys [thinking content tool-calls done error]}]
(cond-> []
(text? thinking) (conj {:type "REASONING_MESSAGE_CONTENT" :delta thinking})
(text? content) (conj {:type "TEXT_MESSAGE_CONTENT" :delta content})
tool-calls (into (mapcat tool-call-events) tool-calls)
done (conj {:type "RUN_FINISHED"})
error (conj {:type "RUN_ERROR" :message error})))
(defn- script-items
"The script's events (in the old shape a test writes; see old->agui) as the pieces of bytes that
arrive, and :pause where the stream waits."
[script]
(mapcat (fn [step]
(if (= :pause step)
[:pause]
(mapcat (fn [event]
(let [bytes (.encode (js/TextEncoder.)
(str "data: " (js/JSON.stringify (clj->js event)) "\n\n"))]
(for [i (range 0 (.-length bytes) piece-size)]
(.subarray bytes i (min (.-length bytes) (+ i piece-size))))))
(old->agui step))))
script))
(defn- stream-reader
"What `response.body.getReader()` gives for a stream of `script`: `read` resolves with a piece
of bytes at a time, then with done. At a :pause it waits for the fn the server holds as :resume."
[script]
(let [items (atom (script-items script))]
(letfn [(read []
(let [item (first @items)]
(swap! items rest)
(cond
(nil? item) (js/Promise.resolve #js {:done true})
(= :pause item) (js/Promise. (fn [resolve]
(swap! server assoc :resume #(resolve (read)))))
:else (js/Promise.resolve #js {:done false :value item}))))]
#js {:read read})))
(defn fake-fetch [uri opts]
(let [opts (js->clj opts :keywordize-keys true)
{:keys [status body script]} (route (:method opts) uri (some-> (:body opts) reader/read-string))]
(js/Promise.resolve
#js {:ok (< status 300) :status status
:text (fn [] (js/Promise.resolve body))
:body #js {:getReader (fn [] (stream-reader script))}})))
(def ^:private real-fetch (.-fetch js/globalThis))
(def fake-server-fixture
"Each test starts with an empty server, nobody logged in, and `fetch` talking to it."
{:before (fn []
(reset! server {:user nil :todos [] :next-id 1})
(aset js/globalThis "fetch" fake-fetch))
:after (fn []
(aset js/globalThis "fetch" real-fetch))})
(def url-fixture
"Each test starts on the page's own address, with no fragment (the page shown is the first), and
with nothing saved in localStorage (e.g. the chat widget's :open?/:size, see
tbd.ui.events/persist-chat-ui) — jsdom's window, and so its localStorage, is shared by every
test in the process."
(let [reset! #(do (set! js/location.hash "") (.clear js/localStorage))]
{:before reset!
:after reset!}))
(defn log-in! [] (swap! server assoc :user {:login "alice" :id 7}))
;; --- Stubbing re-frame effects ---
(defn- set-effect!
"Installs `handler` for effect `id`. (Not reg-fx: that warns about every overwrite.)"
[id handler]
(swap! registrar/kind->id->handler assoc-in [:fx id] handler))
(def ^:private real-effects
"The effect handlers as the app registered them, before any test stubbed one."
(atom {}))
(defn real-effect
"The app's own handler for effect `id`, even while a test has it stubbed."
[id]
(or (get @real-effects id)
(let [handler (registrar/get-handler :fx id)]
(swap! real-effects assoc id handler)
handler)))
(defn stub-effects-fixture
"A fixture that replaces re-frame effects for the length of a test. `stubs` is a map of effect
id to a function of the effect's value, which is called instead of the real handler."
[stubs]
{:before (fn []
(doseq [[id handler] stubs]
(real-effect id)
(set-effect! id handler)))
:after (fn []
(doseq [id (keys stubs)]
(set-effect! id (real-effect id))))})
;; --- Driving the page ---
(defn- poll
"A promise of {:ok? bool :value v}: `(f)` as soon as it is truthy, or its last value after about
a second. The page updates asynchronously (re-frame queues events, React renders in the
background), so tests wait for what they expect to show up rather than for a fixed time."
[f]
(js/Promise.
(fn [resolve]
(let [start (js/Date.now)
check (fn check []
(let [v (f)]
(cond
v (resolve {:ok? true :value v})
(> (- (js/Date.now) start) 1000) (resolve {:ok? false :value v})
:else (js/setTimeout check 2))))]
(check)))))
(defn eventually
"A promise of `(f)`, once it is truthy. If it isn't within about a second the test fails (with
the place that waited), so a wait that can't succeed doesn't pass unnoticed."
[f]
(let [waited-at (js/Error. "timed out waiting for the page")]
(-> (poll f)
(.then (fn [{:keys [ok? value]}]
(when-not ok?
(t/do-report {:type :fail :message "timed out waiting for the page"
:expected "the condition to become true"
:actual (str "still " (pr-str value) "\n" (.-stack waited-at))}))
value)))))
(defn q
"The first element of the page matching CSS `selector`, or nil."
[selector]
(.querySelector js/document selector))
(defn q-all [selector]
(vec (.querySelectorAll js/document selector)))
(defn text
"The text of the first element matching `selector`, or nil when there is none."
[selector]
(some-> (q selector) .-textContent))
(defn shows
"A promise that checks that the text of `selector` becomes `expected` (`what` says what it is)."
[what selector expected]
(-> (poll #(= expected (text selector)))
(.then (fn [_] (is (= expected (text selector)) what)))))
(defn by-label
"The element whose aria-label is `label`."
[label]
(q (str "[aria-label=\"" label "\"]")))
(defn click! [el]
(.click ^js el))
(defn type!
"Types `value` into an input: sets it the way the browser does and fires `input`, which is
what React's onChange listens to."
[el value]
;; window.Event, not the global one: under Node that is Node's own, which jsdom rejects.
(let [setter (.-set (js/Object.getOwnPropertyDescriptor js/HTMLInputElement.prototype "value"))]
(.call setter el value)
(.dispatchEvent el (js/window.Event. "input" #js {:bubbles true}))))
(defn submit!
"Submits the form `el` (an event, not requestSubmit, so it doesn't matter what the browser
would validate)."
[el]
(.dispatchEvent el (js/window.Event. "submit" #js {:bubbles true :cancelable true})))
(defonce ^:private root (atom nil))
(defn mount!
"Renders `component` (hiccup) into a fresh #app, as core/init does, and returns a promise."
[component]
(let [container (.getElementById js/document "app")]
(reset! root (rdc/create-root container))
(rdc/render @root component)
(js/Promise.resolve)))
(defn unmount!
"Removes what `mount!` rendered."
[]
(when-let [r @root]
(rdc/unmount r)
(reset! root nil)))
(defn steps
"Runs `fs` one after the other, as a promise: each is called with the result of the previous
one, which may be a promise, and the promise resolves to the result of the last."
[& fs]
(reduce (fn [p f] (.then p f)) (js/Promise.resolve) fs))
(defn finish
"Ends an `async` test when the promise `p` settles; a rejection fails the test."
[p done]
(-> p
(.then (fn [_] (done)))
(.catch (fn [e]
(t/do-report {:type :error :message "Uncaught exception, not in assertion."
:expected nil :actual e})
(done)))))
(def page-fixture
"Leaves the page empty after each test."
{:after unmount!})
+17 -1
View File
@@ -1,10 +1,13 @@
(ns tbd.ui.tictactoe-test
(:require [cljs.test :refer [deftest is testing]]
(:require [cljs.test :refer [deftest is testing use-fixtures]]
[re-frame.core :as rf]
[re-frame.db :as rf-db]
[tbd.ui.events :as events]
[tbd.ui.test-util :as tu]
[tbd.ui.tictactoe :as ttt]))
(use-fixtures :each tu/url-fixture)
(defn- board
"A board from a string of 9 characters: x, o or anything else for an empty cell."
[s]
@@ -70,3 +73,16 @@
(testing "a draw"
(move! 0 1 2 4 3 5 7 6 8)
(is (= :draw (:outcome (game)))))))
(deftest persistence-test
(rf/dispatch-sync [::events/initialize])
(move! 0 3)
(testing "a reload finds the game where it was left"
(rf/dispatch-sync [::events/initialize])
(let [{:keys [board turn]} (:ttt @rf-db/app-db)]
(is (= [:x nil nil :o] (subvec board 0 4)))
(is (= :x turn))))
(testing "a reset is also remembered"
(rf/dispatch-sync [::events/ttt-reset])
(rf/dispatch-sync [::events/initialize])
(is (= ttt/new-board (:board (:ttt @rf-db/app-db))))))
File diff suppressed because it is too large Load Diff
+433 -95
View File
@@ -1,76 +1,52 @@
(ns tbd.ui.webmcp-test
(:require [cljs.reader :as reader]
[cljs.test :refer [deftest is testing async use-fixtures]]
(:require [cljs.test :refer [deftest is testing async use-fixtures]]
[clojure.string :as str]
[re-frame.core :as rf]
[re-frame.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]))
;; A fake browser: the page's server, and the WebMCP registry the tools end up in.
(def ^:private server
"What the fake server holds: {:user nil-or-{:login ..}, :todos [..], :next-id n}."
(atom nil))
(defn- respond [status body]
{:status status :body (pr-str body)})
(defn- route [method uri body]
(let [{:keys [user todos]} @server
todo-id (some->> (re-find #"^/api/todos/(\d+)$" uri) second js/parseInt)]
(cond
(= "/auth/me" uri) (if user (respond 200 user) (respond 401 {:error "not logged in"}))
(and (= "GET" method) (re-find #"^/api/add\?" uri))
(let [[_ x y] (re-find #"x=([^&]*)&y=([^&]*)" uri)]
(if-let [error (:add-error @server)]
(respond 400 {:error error :details {:x ["is wrong"]}})
(respond 200 {:result (+ (js/parseFloat x) (js/parseFloat y))})))
(not user) (respond 401 {:error "not logged in"})
(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
:created-at 1 :updated-at 1}]
(swap! server #(-> % (update :todos conj todo) (update :next-id inc)))
(respond 201 todo))
(respond 400 {:error "Invalid body" :details {:title ["must not be blank"]}}))
(and (= "PATCH" method) todo-id)
(if-let [todo (first (filter #(= todo-id (:id %)) todos))]
(let [changed (merge todo body)]
(swap! server update :todos (fn [ts] (mapv #(if (= todo-id (:id %)) changed %) ts)))
(respond 200 changed))
(respond 404 {:error "todo not found"}))
(and (= "DELETE" method) todo-id)
(do (swap! server update :todos (fn [ts] (filterv #(not= todo-id (:id %)) ts)))
(respond 200 {:deleted true}))
:else (respond 404 {:error "not found"}))))
(defn- fake-fetch [uri opts]
(let [opts (js->clj opts :keywordize-keys true)
{:keys [status body]} (route (:method opts) uri (some-> (:body opts) reader/read-string))]
(js/Promise.resolve
#js {:ok (< status 300) :status status :text (fn [] (js/Promise.resolve body))})))
;; A fake browser: the page's server (tbd.ui.test-util), and the WebMCP registry the tools end up in.
(def ^:private registered
"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}))})
(def ^:private real-fetch (.-fetch js/globalThis))
: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! server {:user nil :todos [] :next-id 1})
(aset js/globalThis "fetch" fake-fetch))
:after (fn []
(aset js/globalThis "fetch" real-fetch))})
(reset! registered-prompts {})
(reset! registered-resources {})
((:before tu/fake-server-fixture)))
:after (:after tu/fake-server-fixture)})
(defn- call
"A promise of the result of the tool `tool-name` on `args`, as {:text :error?}."
@@ -95,8 +71,6 @@
(rf/dispatch-sync [::events/initialize])
(webmcp/register-tools! fake-mcp))
(defn- log-in! [] (swap! server assoc :user {:login "alice" :id 7}))
(deftest registers-the-tools
(is (identical? fake-mcp (webmcp/register-tools! fake-mcp)))
(is (= (set (map :name webmcp/tools)) (set (keys @registered))))
@@ -107,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)
@@ -139,7 +114,7 @@
(done))))))
(deftest add-shows-the-servers-error
(swap! server assoc :add-error "Invalid parameters")
(swap! tu/server assoc :add-error "Invalid parameters")
(open-page!)
(async done
(-> (page-loaded)
@@ -153,6 +128,33 @@
(is (re-find #"must be numbers" (:text r)))
(done))))))
(deftest login-state-unavailable
;; The server can't say who is logged in: the tools that need to know say so.
(aset js/globalThis "fetch"
(fn [_ _] (js/Promise.resolve #js {:ok false :status 500
:text (fn [] (js/Promise.resolve (pr-str {:error "Boom"})))})))
(open-page!)
(async done
(-> (call "whoami" {})
(.then (fn [r]
(is (= {:text "could not tell who is logged in: Boom" :error? false} r))
(call "list_todos" {})))
(.then (fn [r]
(is (= {:text "could not tell who is logged in: Boom" :error? true} r))
(done))))))
(deftest add-while-adding
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_]
;; A person pressed Add a moment ago and the sum hasn't come back.
(rf/dispatch-sync [::events/add])
(call "add" {:x 1 :y 2})))
(.then (fn [r]
(is (= {:text "an addition is already in progress" :error? true} r))
(done))))))
(deftest anonymous-user
(open-page!)
(async done
@@ -163,15 +165,183 @@
(.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 @server)) "nothing was sent")
(is (empty? (:todos @tu/server)) "nothing was sent")
(done))))))
;; A tool that acts on the page opens the page it acts on, as a click on its tab would.
(defn- page [] (:page @rf-db/app-db))
(deftest tools-open-the-page-they-act-on
(tu/log-in!)
(swap! tu/server assoc :todos [{:id (tu/todo-uuid 1) :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
:next-id 2)
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_]
(rf/dispatch-sync [::events/navigate :ai-setup])
(call "get_tic_tac_toe" {})))
(.then (fn [_]
(is (= :ai-setup (page)) "reading changes nothing")
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
(.then (fn [_]
(is (= :tic-tac-toe (page)))
(rf/dispatch-sync [::events/navigate :ai-setup])
(call "add" {:x 1 :y 2})))
(.then (fn [_]
(is (= :calculator (page)) "the calculator is on its own page")
(call "list_todos" {})))
(.then (fn [_]
(is (= :calculator (page)))
(call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [_]
(is (= :todos (page)))
(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 :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 (= {:text "ok" :error? false} r) "nothing left to say: the page shows it, and so will the next state")
(is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items]))))
(is (= :todos (page)))
;; A bad entry, or an unknown todo, refuses the whole batch before anything changes.
(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 (= {:text "ok" :error? false} r))
(is (= ["milk" "eggs" "bread"] (map :title (get-in @rf-db/app-db [:todos :items]))) "in the order given")
(is (= :todos (page)))
(call "get_todo" {:todos [{:id (tu/todo-uuid 3)} {:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(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 (= {:text "ok" :error? false} r) "a repeated id is deleted once, not refused as unknown the second time")
(is (= ["bread"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(is (= ["bread"] (map :title (:todos @tu/server))))
;; The server refuses a blank title, which the page only sees after the first was added.
(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
(-> (page-loaded)
(.then #(call "navigate" {:page "ai-setup"}))
(.then (fn [r]
(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 "tic-tac-toe"})))
(.then (fn [r]
(is (false? (:error? r)))
(is (= :tic-tac-toe (page)))
(call "navigate" {:page "nowhere"})))
(.then (fn [r]
(is (:error? 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})))
(.then (fn [r]
(is (:error? r) "the page is the name of one")
(call "navigate" {})))
(.then (fn [r]
(is (:error? r))
(is (= :ai-setup (page)) "a refused navigation leaves the page where it was")
(done))))))
(deftest navigate-to-a-page-that-needs-a-login
(open-page!)
(async done
(-> (page-loaded)
(.then #(call "navigate" {:page "todos"}))
(.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 (= :tic-tac-toe (page)))
(done))))))
(deftest navigate-to-the-todos-when-logged-in
(tu/log-in!)
(open-page!)
(async done
(-> (page-loaded)
(.then #(call "navigate" {:page "todos"}))
(.then (fn [r]
(is (= {:text "{\"page\":\"todos\",\"title\":\"Todos\"}" :error? false} r))
(is (= :todos (page)))
(done))))))
(deftest a-tool-that-fails-leaves-the-page-alone
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_] (call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [r]
(is (:error? r) "not logged in")
(is (= :tic-tac-toe (page)) "so there is no todos page to go to")
(done))))))
(deftest todos
(log-in!)
(swap! server assoc :todos [{:id 1 :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
(tu/log-in!)
(swap! tu/server assoc :todos [{:id (tu/todo-uuid 1) :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
:next-id 2)
(open-page!)
(async done
@@ -181,54 +351,58 @@
(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 (= {:text "ok" :error? false} r))
;; The page shows it, and the field is empty again.
(is (= ["old" "buy milk"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(is (= "" (get-in @rf-db/app-db [:todos :new-title])))
(call "set_todo_done" {: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 (= {:text "ok" :error? false} r))
(is (true? (:done (last (get-in @rf-db/app-db [:todos :items])))))
;; Already ticked: nothing to do, and no request.
(swap! server assoc :todos [])
(call "set_todo_done" {:id 2 :done true})))
(swap! tu/server assoc :todos [])
(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 (= {:text "ok" :error? false} r) "still nothing to do: the now-empty server list was never asked")
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done "yes"}]})))
(.then (fn [r]
(is (:error? r))
(call "delete_todo" {:id 1})))
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(is (= {:text "deleted" :error? false} r))
(is (= {:text "ok" :error? false} r))
(is (= ["buy milk"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(call "delete_todo" {: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))))))
(deftest create-todo-shows-the-servers-error
(log-in!)
(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)))
(is (empty? (get-in @rf-db/app-db [:todos :items])))
(done))))))
(deftest tic-tac-toe-tools-are-once-per-turn
;; A move is the person's to ask for again, not the model's to repeat on its own: tbd.ui.events
;; (see its once-per-turn tests) only lets the chatbot's turn call it once.
(is (true? (:once-per-turn? (first (filter #(= "move_tic_tac_toe" (:name %)) webmcp/tools))))))
(deftest tic-tac-toe
(open-page!)
(async done
@@ -236,24 +410,35 @@
(.then (fn [r]
(is (false? (:error? r)))
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
(call "move_tic_tac_toe" {:cell 4})))
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
(.then (fn [r]
;; It pressed the cell, as a user would, and says it is O's turn now.
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
;; It pressed the cell, as a user would; the result says the board it left (see
;; provider-for's tic-tac-toe assertions for the shape it takes in the state).
(is (false? (:error? r)))
(is (= {:board [nil nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "o"}
(json (:text r))))
(call "move_tic_tac_toe" {:cell 4})))
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
(is (= :o (get-in @rf-db/app-db [:ttt :turn])) "it is O's turn now")
(call "move_tic_tac_toe" {:cell 4 :player "o"})))
(.then (fn [r]
(is (= {:text "cell 4 is taken" :error? true} r))
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])) "the mark on the taken cell stays")
(is (= :o (get-in @rf-db/app-db [:ttt :turn])) "and the refused move does not use up the turn")
(call "move_tic_tac_toe" {:cell 0 :player "x"})))
(.then (fn [r]
(is (= {:text "it is o's turn, not x's" :error? true} r))
(is (:error? r))
(is (re-find #"it is o's turn, not x's" (:text r)))
(is (nil? (get-in @rf-db/app-db [:ttt :board 0])) "nothing was moved")
(call "move_tic_tac_toe" {:cell 9})))
(call "move_tic_tac_toe" {:cell 0})))
(.then (fn [r]
(is (:error? r) "the side is required: no moving for whoever's turn it is")
(is (re-find #"player must be" (:text r)))
(is (nil? (get-in @rf-db/app-db [:ttt :board 0])) "nothing was moved")
(call "move_tic_tac_toe" {:cell 9 :player "o"})))
(.then (fn [r]
(is (:error? r))
(is (re-find #"0 to 8" (:text r)))
(call "move_tic_tac_toe" {:cell 1.5})))
(call "move_tic_tac_toe" {:cell 1.5 :player "o"})))
(.then (fn [r]
(is (:error? r))
(call "move_tic_tac_toe" {:cell 0 :player "z"})))
@@ -261,19 +446,172 @@
(is (:error? r))
(call "move_tic_tac_toe" {:cell 0 :player "o"})))
(.then (fn [r]
(is (= "x" (:turn (json (:text r)))))
(is (false? (:error? r)))
(is (= {:board ["o" nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "x"}
(json (:text r))))
(is (= :x (get-in @rf-db/app-db [:ttt :turn])))
;; The person moves X to 3 and O to 1; the agent's X then completes the middle row.
(rf/dispatch-sync [::events/ttt-move 3])
(rf/dispatch-sync [::events/ttt-move 1])
(call "move_tic_tac_toe" {:cell 5 :player "x"})))
(.then (fn [r]
(is (false? (:error? r)))
(is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil]
:status "won" :winner "x" :line [3 4 5]}
(json (:text r))))
(call "move_tic_tac_toe" {:cell 8})))
(is (= [:o :o nil :x :x :x nil nil nil] (get-in @rf-db/app-db [:ttt :board])) "X won the middle row")
(call "move_tic_tac_toe" {:cell 8 :player "o"})))
(.then (fn [r]
(is (= {:text "the game is over: start a new game" :error? true} r))
(call "new_tic_tac_toe_game" {})))
(.then (fn [r]
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
(is (= {:text "the game is over: the person starts a new one, with the page's own New game button"
:error? true}
r))
(done))))))
;; --- State (tbd.ui.model-context's registry, filled from webmcp/state-providers) ---
(defn- provider-for
"The `:provide` fn of the state provider registered for exactly `pages`."
[pages]
(:provide (first (filter #(= pages (:pages %)) webmcp/state-providers))))
(deftest calculator-state-provider-test
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_]
(is (= {:x "" :y "" :result {:status :idle}} ((provider-for #{:calculator}))))
(call "add" {:x 2 :y 3})))
(.then (fn [_]
(is (= {:x "2" :y "3" :result {:status :ok :x "2" :y "3" :sum 5}}
((provider-for #{:calculator}))))
(done))))))
(deftest tic-tac-toe-state-provider-test
(open-page!)
;; Raw, as tbd.ui.tictactoe keeps it (:x/:o, not the "x"/"o" strings get_tic_tac_toe's JSON gave:
;; there is no JSON round trip here, only on the wire to the server).
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn :x} ((provider-for #{:tic-tac-toe})))
"the same state get_tic_tac_toe used to hand back")
(async done
(-> (call "move_tic_tac_toe" {:cell 4 :player "x"})
(.then (fn [_]
(is (= {:board [nil nil nil nil :x nil nil nil nil] :status "in_progress" :turn :o}
((provider-for #{:tic-tac-toe}))))
(done))))))
(deftest todos-state-provider-test
(testing "nothing until the todos have loaded (no login, or not fetched yet): not an empty list,
which would read as \"there are none\""
(is (nil? ((provider-for #{:todos})))))
(tu/log-in!)
(swap! tu/server assoc :todos [{:id (tu/todo-uuid 1) :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
:next-id 2)
(open-page!)
(async done
(-> (call "list_todos" {}) ; waits for the load, the way logged-in-todos does
(.then (fn [_]
(is (= {:todos [{:id (tu/todo-uuid 1) :title "old" :done false}]} ((provider-for #{:todos}))))
(call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [_]
(is (= ["old" "buy milk"] (map :title (:todos ((provider-for #{:todos}))))))
(done))))))
;; --- Prompts and resources ---
(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 (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 "no side is assigned by the prompt; the tools and state carry the game"
(is (= prompt/tic-tac-toe (:text (prompt-text "play_tic_tac_toe" nil))))
(is (re-find #"get_tic_tac_toe and move_tic_tac_toe"
(:text (prompt-text "play_tic_tac_toe" {:side "x"}))))))
(deftest registers-the-resources
(is (identical? fake-mcp (webmcp/register-resources! fake-mcp)))
(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))))))