Compare commits
29 Commits
4e0ddb601d
..
main
| Author | SHA1 | Date | |
|---|---|---|---|
| d884ca4179 | |||
| 2637b69c2c | |||
| a6f49938dc | |||
| 2d606d0620 | |||
| a7f12b5d72 | |||
| 6569a69463 | |||
| a3ef6ec077 | |||
| 187252177c | |||
| bf38f7b1be | |||
| a53f0c3621 | |||
| 10f4ca654b | |||
| 47f6cbf2d1 | |||
| 1926432fc6 | |||
| 8799c1e14c | |||
| 7f0e58240d | |||
| a76f326ae3 | |||
| 59030c2fa0 | |||
| f07d68b832 | |||
| 1f907cfe7b | |||
| 5aaf5a8d6c | |||
| aa4f8ea86a | |||
| 64d1a35da2 | |||
| 31e03d552b | |||
| b1783e3f85 | |||
| 6ff03a45f7 | |||
| d9499594bf | |||
| 3b0b608d7d | |||
| a46428a757 | |||
| 0e3ea5a714 |
+6
-1
@@ -1,3 +1,8 @@
|
||||
target
|
||||
**/target
|
||||
.cpcache
|
||||
.git
|
||||
**/node_modules
|
||||
**/.shadow-cljs
|
||||
resources/public/js
|
||||
.env
|
||||
data
|
||||
|
||||
@@ -0,0 +1,69 @@
|
||||
# Copy to .env and fill in: cp .env-template .env
|
||||
# script/server loads .env automatically; with Docker pass it via `docker run --env-file .env`
|
||||
# (so keep values unquoted). .env is git-ignored and excluded from the image; never commit it.
|
||||
|
||||
# --- Server ---------------------------------------------------------------
|
||||
# PORT=3000
|
||||
|
||||
# --- Gitea OAuth login ------------------------------------------------------
|
||||
# Register an OAuth2 application in Gitea (Settings > Applications) as a confidential
|
||||
# client, with the redirect URI <BASE_URL>/auth/callback
|
||||
GITEA_URL=https://gitea.example.com
|
||||
GITEA_CLIENT_ID=
|
||||
GITEA_CLIENT_SECRET=
|
||||
|
||||
# Public URL of this app, as the browser reaches it. Use https in production: that also
|
||||
# marks the session cookie Secure.
|
||||
BASE_URL=http://localhost:3000
|
||||
|
||||
# Signs and encrypts session cookies. Generate with: openssl rand -hex 32
|
||||
# Unset = a random key per start, so everyone is logged out on every restart.
|
||||
SESSION_SECRET=
|
||||
|
||||
# --- Admin API --------------------------------------------------------------
|
||||
# Comma-separated Gitea usernames allowed to use the admin API (POST /nrepl).
|
||||
# Empty = nobody can.
|
||||
ADMIN_USERS=
|
||||
|
||||
# --- 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
|
||||
|
||||
# --- 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
|
||||
# https://developer.chrome.com/origintrials and paste the token here: the server then sends it
|
||||
# as an `Origin-Trial` header on the page, and Chrome turns WebMCP on for everyone who opens it.
|
||||
# The token is only good for that exact origin (scheme, host and port), and expires with the trial.
|
||||
# Empty = no header (in Chrome you can still enable chrome://flags/#enable-webmcp-testing).
|
||||
WEBMCP_ORIGIN_TRIAL_TOKEN=
|
||||
|
||||
# --- nREPL debug server (POST /nrepl) -----------------------------------------
|
||||
# nREPL has no authentication and evaluates arbitrary code, so it listens on loopback
|
||||
# only by default. Changing NREPL_BIND to 0.0.0.0 exposes it to the network: only do that
|
||||
# behind a firewall or an SSH tunnel.
|
||||
# NREPL_PORT=7888
|
||||
# NREPL_BIND=127.0.0.1
|
||||
@@ -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
|
||||
|
||||
|
||||
+12
-1
@@ -1,3 +1,14 @@
|
||||
.cpcache
|
||||
target
|
||||
|
||||
node_modules
|
||||
.shadow-cljs
|
||||
# Compiled UI (script/ui-build)
|
||||
resources/public/js
|
||||
.nrepl-port
|
||||
# clj-kondo / clojure-lsp caches
|
||||
.clj-kondo
|
||||
.lsp
|
||||
# Local SQLite database (DB_PATH)
|
||||
data
|
||||
# Local secrets (copy .env-template to .env)
|
||||
.env
|
||||
|
||||
+38
-6
@@ -1,10 +1,41 @@
|
||||
FROM clojure:openjdk-11-tools-deps
|
||||
# Stage 1: compile the re-frame UI (ui/) to JS. shadow-cljs needs Node and a JVM. It writes
|
||||
# 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).
|
||||
# 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 sed -i \
|
||||
-e 's|deb.debian.org/debian|archive.debian.org/debian|g' \
|
||||
-e '/security.debian.org/d' \
|
||||
/etc/apt/sources.list \
|
||||
&& apt-get update && apt-get install -y --no-install-recommends curl \
|
||||
RUN apt-get update \
|
||||
&& apt-get install -y --no-install-recommends default-jre-headless \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
|
||||
WORKDIR /build/ui
|
||||
COPY ui/package.json ui/package-lock.json ./
|
||||
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
|
||||
|
||||
RUN apt-get update && apt-get install -y --no-install-recommends curl \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
|
||||
WORKDIR /app
|
||||
@@ -17,6 +48,7 @@ RUN clojure -P -X:${DEPS_ALIASES} \
|
||||
&& echo "[build] cached jars: $(find /root/.m2 -name '*.jar' | wc -l)"
|
||||
|
||||
COPY . .
|
||||
COPY --from=ui /build/resources/public/js resources/public/js
|
||||
|
||||
EXPOSE 3000
|
||||
|
||||
|
||||
@@ -1,17 +1,19 @@
|
||||
# tbd
|
||||
|
||||
A small Clojure HTTP API built on [Ring](https://github.com/ring-clojure/ring) (Jetty) and
|
||||
[reitit](https://github.com/metosin/reitit), with Swagger UI docs, unit tests, dockerized
|
||||
integration tests, and joint line coverage.
|
||||
[reitit](https://github.com/metosin/reitit), with a ClojureScript
|
||||
[re-frame](https://github.com/day8/re-frame) front end (`ui/`), Swagger UI docs, unit tests,
|
||||
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 11+, 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
|
||||
|
||||
```bash
|
||||
script/ui-build # compile the UI (once, and after UI changes)
|
||||
script/server [port]
|
||||
```
|
||||
|
||||
@@ -23,7 +25,9 @@ script/server 8080
|
||||
PORT=8080 script/server
|
||||
```
|
||||
|
||||
This is a thin wrapper around `clojure -X:run`, which also honors `PORT`.
|
||||
This is a thin wrapper around `clojure -X:run`, which also honors `PORT`. Then open
|
||||
http://localhost:3000 for the UI. Without `script/ui-build` the server still starts, but `/`
|
||||
shows a placeholder.
|
||||
|
||||
Or build and run the container:
|
||||
|
||||
@@ -36,17 +40,426 @@ docker run --rm -p 3000:3000 tbd
|
||||
|
||||
| Method | Path | Description |
|
||||
|--------|------|-------------|
|
||||
| `GET` | `/` | Plain-text landing message |
|
||||
| `GET` | `/` | The UI: an HTML shell that loads the compiled ClojureScript from `/js/main.js` |
|
||||
| `GET` | `/api/ping` | Health check, returns `pong` |
|
||||
| `GET` | `/api/add?x=2&y=3` | Adds two numbers, returns EDN: `{:result 5}` (400 if either is missing or not a number) |
|
||||
| `GET` | `/api/add?x=2&y=3` | Adds two numbers: `{:result 5}` (EDN by default, see [Formats](#formats)) (400 if either is missing or not a number) |
|
||||
| `POST`, `DELETE` | `/mcp` | The [MCP server](#mcp-server) (JSON-RPC over Streamable HTTP; `DELETE` ends a session; `GET` is `405`). **Needs an OAuth access token** (`401` without one) |
|
||||
| `GET` | `/.well-known/oauth-protected-resource`, `/.well-known/oauth-authorization-server` | The [MCP OAuth](#connecting-an-mcp-client) discovery documents (RFC 9728 and 8414) |
|
||||
| `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 "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) |
|
||||
| `DELETE` | `/api/todos/:id` | **Login required.** Deletes the todo: `{:deleted true}` (404 as above) |
|
||||
| `GET` | `/nrepl` | **Admin only.** Whether the nREPL debug server is on: `{:enabled false}`, or `{:enabled true :bind "127.0.0.1" :port 7888}` |
|
||||
| `POST` | `/nrepl` | **Admin only.** Body `{"enabled": true}` (JSON or EDN) starts the nREPL debug server, `false` stops it; returns `{:enabled true :bind "127.0.0.1" :port 7888}` |
|
||||
|
||||
```bash
|
||||
curl localhost:3000/api/ping # pong
|
||||
curl 'localhost:3000/api/add?x=2&y=3' # {:result 5}
|
||||
curl 'localhost:3000/api/add?x=2&y=3' -H 'Accept: application/json' # {"result":5}
|
||||
```
|
||||
|
||||
## Formats
|
||||
|
||||
The API speaks EDN, JSON and Transit (`application/transit+json`, `application/transit+msgpack`).
|
||||
Responses follow the request's `Accept` header, and request bodies are read by their `Content-Type`.
|
||||
**EDN is the default**: with no `Accept` (or `*/*`, or a type the API can't produce) you get EDN, and a
|
||||
body sent with no `Content-Type` is read as EDN. Errors (400, 401, 403, ...) use the same format
|
||||
as everything else. Two exceptions: `/api/ping` is always `text/plain`, and `/swagger.json` is always JSON.
|
||||
|
||||
Handlers return plain data (`(tbd.http/respond 200 {:result 5})`), and the muuntaja middleware in
|
||||
`tbd.core` encodes it; don't `pr-str` a body yourself.
|
||||
|
||||
## Todos
|
||||
|
||||
Each logged-in user has their own todo list, keyed by their Gitea user id. Every query is
|
||||
filtered by that id, so users can't see or change each other's todos; someone else's todo answers
|
||||
`404`, exactly like a missing one. Without a login the todo routes answer `401`. The operations
|
||||
themselves (ownership, validation, storage) live in `src/tbd/todo/service.clj`, which the HTTP routes
|
||||
and the [MCP tools](#mcp-server) both call, so they behave the same and are tested once; a route or
|
||||
tool only translates its request into a service call and the result into a response, and never
|
||||
touches the database.
|
||||
|
||||
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:
|
||||
curl -XPOST localhost:3000/api/todos -H 'Cookie: tbd-session=...' \
|
||||
-H 'Content-Type: application/json' -d '{"title": "buy milk"}'
|
||||
curl localhost:3000/api/todos -H 'Cookie: tbd-session=...'
|
||||
```
|
||||
|
||||
## MCP server
|
||||
|
||||
The server also speaks [MCP](https://modelcontextprotocol.io/) (Model Context Protocol) at `/mcp`,
|
||||
built on [PluMCP](https://github.com/plumce/plumcp) and running inside this same process; there is
|
||||
nothing extra to start. It uses the Streamable HTTP transport, and, like the todo API, it acts **as
|
||||
the logged-in user**: a client has to be approved by a user first (see below), and from then on
|
||||
every tool call knows who is calling.
|
||||
|
||||
```bash
|
||||
claude mcp add --transport http tbd https://tbd.example.com/mcp # <BASE_URL>/mcp
|
||||
```
|
||||
|
||||
The first time the client connects it gets a `401`, opens your browser, you log in with Gitea
|
||||
as usual and approve the client, and the client keeps its tokens from then on. It needs the
|
||||
[Gitea login](#authentication-and-the-admin-api) to be configured, including `BASE_URL` (which must
|
||||
be the address the client uses; without them `/mcp` answers `503` rather than being open).
|
||||
|
||||
It offers these tools: `ping`, `add` (the same logic as `/api/add`), `whoami` (which user this
|
||||
connection acts as, and whether they are an admin), and, on the caller's own todos (the same ones
|
||||
as `/api/todos`), `list_todos`, `get_todo`, `create_todo`, `update_todo` and `delete_todo`. To add a
|
||||
tool, add a `tool` to `src/tbd/mcp/tools.clj`; it should call the group's service (or pure `core`
|
||||
functions), not a database, and if the group has no service yet, that is the thing to add, so the
|
||||
HTTP routes can share it. Its arguments are described by the group's
|
||||
[Malli](https://github.com/metosin/malli) schema in `src/tbd/<group>/schema.clj`, the same schema the
|
||||
HTTP routes use for their parameters, so a shape of data is written down once: the tool's
|
||||
input schema is generated from it, and the arguments a client sends are coerced and validated against
|
||||
it (plumcp only checks that required ones are present). A tool that touches a user's data or does
|
||||
something admin-only gets the caller from `current-user` there (`{:login :id :admin? :client-id}`),
|
||||
and must not trust anything else about who is asking.
|
||||
|
||||
(The UI has tools of its own for a browser agent, [see below](#browser-mcp-tools-webmcp); they are not part of this server.)
|
||||
|
||||
Sessions are kept in memory, so they end when the server restarts (clients just re-initialize; their
|
||||
tokens are in the database and keep working). Server-to-client streaming (`GET /mcp`) is deliberately
|
||||
off: nothing here pushes messages, and the response would hang under Jetty. PluMCP needs JDK 21+.
|
||||
|
||||
### Connecting an MCP client
|
||||
|
||||
tbd is its own OAuth 2.1 authorization server for `/mcp` (in `src/tbd/oauth/`), with the Gitea login
|
||||
as the way a user proves who they are. Gitea's own tokens never reach an MCP client, and the tokens
|
||||
tbd issues are worth nothing anywhere else. The flow is the one the
|
||||
[MCP authorization spec](https://modelcontextprotocol.io/specification/2025-06-18/basic/authorization)
|
||||
describes, so any compliant client does it by itself:
|
||||
|
||||
1. `POST /mcp` with no token gets `401` and `WWW-Authenticate: Bearer resource_metadata="<BASE_URL>/.well-known/oauth-protected-resource/mcp"`.
|
||||
2. The client reads that document, then `/.well-known/oauth-authorization-server`, and registers itself at
|
||||
`/oauth/register` (dynamic client registration, public clients only).
|
||||
3. It opens `/oauth/authorize` in the browser (authorization-code flow, PKCE `S256` required). If you aren't
|
||||
logged in you go through the Gitea login first and come back; then a consent page names the client and
|
||||
the address you'll be sent back to, and asks you to **Approve** or **Deny**.
|
||||
4. The client trades the code at `/oauth/token` for an access token (1 hour) and a refresh token (30 days,
|
||||
rotated on every use), and sends `Authorization: Bearer ...` on every `/mcp` request.
|
||||
|
||||
The consent page is what stops a stranger's client (anyone can register one) from getting a token by
|
||||
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 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.
|
||||
Anyone with a Gitea account can log in, but routes marked `:admin? true` (currently
|
||||
`GET` and `POST /nrepl`) also require the user to be on the `ADMIN_USERS` allowlist: **401** without a
|
||||
login, **403** for a logged-in non-admin. With no allowlist, nobody is an admin.
|
||||
|
||||
1. In Gitea (Settings > Applications) create an OAuth2 application, a confidential client, with
|
||||
the redirect URI `<BASE_URL>/auth/callback`.
|
||||
2. `cp .env-template .env` and fill it in. `script/server` loads `.env`; for Docker use
|
||||
`docker run --env-file .env`. `.env` is git-ignored and kept out of the image.
|
||||
|
||||
| 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 and A2A servers: the OAuth issuer, what MCP clients are told to use (`<BASE_URL>/mcp`), and the A2A AgentCard's `url` (`<BASE_URL>/a2a`) |
|
||||
| `ADMIN_USERS` | Comma-separated Gitea usernames (case-insensitive) allowed to use the admin API |
|
||||
| `SESSION_SECRET` | Signs and encrypts session cookies. Unset = a random key per start, so logins don't survive a restart |
|
||||
| `DB_PATH` | The app's SQLite file: todos, and the MCP OAuth server's registered clients, codes and tokens (default `data/tbd.db`). Mount a volume for it in Docker, or todos are lost and every MCP client has to be approved again after each restart |
|
||||
| `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
|
||||
(enforced server-side). The cookie is stateless, so `POST /auth/logout` clears it in the browser but
|
||||
can't revoke a copy someone already captured; it just expires on its own.
|
||||
|
||||
### The nREPL endpoint
|
||||
|
||||
```bash
|
||||
# after logging in in a browser, copy the `tbd-session` cookie value:
|
||||
curl -XPOST localhost:3000/nrepl -H 'Cookie: tbd-session=...' \
|
||||
-H 'Content-Type: application/json' -d '{"enabled": true}'
|
||||
clj -Sdeps '{:deps {nrepl/nrepl {:mvn/version "1.2.0"}}}' -M -m nrepl.cmdline --connect --host 127.0.0.1 --port 7888
|
||||
```
|
||||
|
||||
nREPL has no authentication and evaluates arbitrary code, so enabling it is effectively remote code
|
||||
execution for whoever can reach the port. It therefore binds to loopback by default; reach it through
|
||||
an SSH tunnel (or `docker exec`) rather than setting `NREPL_BIND=0.0.0.0`. Each enable/disable is
|
||||
logged with the admin's Gitea username. It stays on until an admin disables it (or the server
|
||||
restarts), so switch it off when you're done.
|
||||
|
||||
## UI
|
||||
|
||||
`ui/` is a [re-frame](https://github.com/day8/re-frame) app (ClojureScript, React 19 via
|
||||
[Reagent](https://reagent-project.github.io/)) built with [shadow-cljs](https://github.com/thheller/shadow-cljs).
|
||||
It has 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 `/`.
|
||||
|
||||
| Task | What it does |
|
||||
|------|--------------|
|
||||
| `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 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. 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` | 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`
|
||||
(restart Claude Desktop afterwards).
|
||||
2. Ask the client to *make a webmcp token*.
|
||||
3. Click the blue square in the bottom right corner of the page, paste the token, and press Connect.
|
||||
The token works once, and the page has no field for it: the widget is where it goes.
|
||||
4. The tools show up in the client, prefixed with the page's host.
|
||||
|
||||
## Development
|
||||
|
||||
Every task is a bash script in `script/`. Start an nREPL server (with CIDER middleware) on the port in `.nrepl-port`, or `3000` if that
|
||||
@@ -61,22 +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, 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.
|
||||
|
||||
@@ -88,10 +514,26 @@ src/tbd/
|
||||
core.clj Router, Ring app, and server startup
|
||||
<group>/routes.clj Each route group (health, math, ...) owns its route subtree
|
||||
<group>/core.clj Business logic for the group, with no HTTP concerns
|
||||
<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 and A2A clients: rules (core), SQLite storage (db), `/oauth` + discovery routes, and the bearer-token middleware guarding `/mcp` and `/a2a` (middleware)
|
||||
agent/ The agent: a LangChain4j streaming chat model (core), JSON-Schema translation for tool specs (json_schema), its system prompts (instructions), and the A2A server mounted at `/a2a` (a2a)
|
||||
chat/ /api/chat: the AG-UI wire protocol (routes), the request's Malli schema (schema), per-turn logging and loop detection (trace) — the agent itself is agent/core.clj
|
||||
nrepl/ On-demand nREPL server (core) and the admin-only `/nrepl` routes
|
||||
todo/ Per-user todos: pure rules (core), Malli schemas of the input (schema), SQLite storage (db), `/api/todos` routes
|
||||
shared/ .cljc read by both the server and the UI (tbd.agent.prompt: the instructions an 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 (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`.
|
||||
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`, with a `migrate!` fn for its tables in the app's one database;
|
||||
add it to the `sqlite/open` call in `make-router`.
|
||||
|
||||
@@ -1,15 +1,27 @@
|
||||
{: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"}
|
||||
ring/ring-defaults {:mvn/version "0.4.0"}
|
||||
metosin/reitit {:mvn/version "0.7.2"}}
|
||||
metosin/reitit {:mvn/version "0.7.2"}
|
||||
;; Runtime dep: POST /nrepl starts an nREPL server on demand (see tbd.nrepl.core).
|
||||
nrepl/nrepl {:mvn/version "1.2.0"}
|
||||
;; The todo group's storage (see tbd.todo.db): a local SQLite file.
|
||||
com.github.seancorfield/next.jdbc {:mvn/version "1.3.1002"}
|
||||
org.xerial/sqlite-jdbc {:mvn/version "3.46.1.3"}
|
||||
;; 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"}
|
||||
;; 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
|
||||
{:extra-deps
|
||||
{nrepl/nrepl {:mvn/version "1.2.0"}
|
||||
cider/cider-nrepl {:mvn/version "0.48.0"}
|
||||
{cider/cider-nrepl {:mvn/version "0.48.0"}
|
||||
org.babashka/http-client {:mvn/version "0.4.25"}}}
|
||||
:test
|
||||
{:extra-paths ["test"]
|
||||
|
||||
@@ -52,10 +52,25 @@ bb integration-test/integration_test.bb http://localhost:3000 --watch --interval
|
||||
| # | Test | Checks |
|
||||
|---|------|--------|
|
||||
| 1 | `GET /` returns 200 | HTTP status code |
|
||||
| 2 | `Content-Type` header | `text/plain` |
|
||||
| 3 | Response body | Contains expected Clojure/Ring content |
|
||||
| 4 | Not HTML | Confirms plain text response |
|
||||
| 2 | `Content-Type` header | `text/html` |
|
||||
| 3 | Response body | The HTML shell: mount point and `/js/main.js` script tag |
|
||||
| 4 | `GET /js/main.js` | 200, JavaScript, non-empty, contains the UI's `/api/add` call |
|
||||
| 5 | `HEAD /` works | HTTP 200 |
|
||||
| 6 | `GET /api/ping` | 200, body `pong` |
|
||||
| 7 | `GET /swagger.json` | 200, JSON, references `/api/ping` |
|
||||
| 8 | `GET /api-docs` | 200, `text/html` |
|
||||
| 9 | `GET /api/add?x=2&y=3` | 200, EDN `{:result 5}` |
|
||||
| 10 | `GET /api/add` with bad params | 400 for a missing or non-numeric param |
|
||||
| 11 | `GET /auth/login` | 302 to Gitea's authorize URL with the client id and a state; `HttpOnly` cookie |
|
||||
| 12 | `GET /auth/callback` with no login in progress | 400 |
|
||||
| 13 | `GET /auth/me` without a session | 401 |
|
||||
| 14 | `POST /nrepl` without a session | 401, even with an invalid body |
|
||||
|
||||
The app container gets dummy Gitea settings from `docker-compose.yml`, so tests 11-14 cover the
|
||||
unauthenticated surface only; completing a login needs a real Gitea (the unit tests stub one).
|
||||
|
||||
Test 4 needs the compiled UI, which the Docker image includes (`script/integration-test`
|
||||
builds it). Against a locally running server, run `script/ui-build` first.
|
||||
|
||||
## Line Coverage
|
||||
|
||||
|
||||
@@ -10,6 +10,13 @@ services:
|
||||
- apparmor:unconfined
|
||||
environment:
|
||||
- PORT=${TBD_PORT:-3000}
|
||||
# Dummy OAuth settings so /auth/login can be exercised; there's no Gitea to complete a login.
|
||||
- BASE_URL=http://tbd-app:${TBD_PORT:-3000}
|
||||
- GITEA_URL=http://gitea.invalid
|
||||
- GITEA_CLIENT_ID=integration-client
|
||||
- GITEA_CLIENT_SECRET=integration-secret
|
||||
- ADMIN_USERS=integration-admin
|
||||
- SESSION_SECRET=integration-session-secret
|
||||
# No container healthcheck: healthchecks run via `docker exec`, which hits the
|
||||
# same LXC/AppArmor runc bug (opencontainers/runc#5007) as image builds and
|
||||
# always fails here. integration_test.bb polls the server until it's ready.
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
|
||||
(ns integration-test
|
||||
(:require [babashka.http-client :as http]
|
||||
[cheshire.core :as json]
|
||||
[clojure.edn :as edn]
|
||||
[clojure.string :as str]))
|
||||
|
||||
@@ -18,6 +19,26 @@
|
||||
(defn head* [base-url]
|
||||
(http/head base-url {:throw false}))
|
||||
|
||||
;; The login redirect points at Gitea; we want to see it, not follow it.
|
||||
(def no-redirect-client (http/client {:follow-redirects :never}))
|
||||
|
||||
(defn get-no-redirect* [url]
|
||||
(http/get url {:throw false :client no-redirect-client}))
|
||||
|
||||
(defn post-json* [url body]
|
||||
(http/post url {:throw false
|
||||
:headers {"Content-Type" "application/json"}
|
||||
:body body}))
|
||||
|
||||
(defn post-form* [url params]
|
||||
(http/post url {:throw false
|
||||
:client no-redirect-client
|
||||
:headers {"Content-Type" "application/x-www-form-urlencoded"}
|
||||
:form-params params}))
|
||||
|
||||
(defn json* [url]
|
||||
(json/parse-string (:body (http/get url))))
|
||||
|
||||
(defn wait-for-server [{:keys [base-url max-retries retry-delay-ms]}]
|
||||
(println (str "=== Waiting for server at " base-url " ==="))
|
||||
(loop [i 1]
|
||||
@@ -68,23 +89,22 @@
|
||||
(assert-eq "HTTP status" 200 (:status (get* base-url)))
|
||||
(println)
|
||||
|
||||
(println "Test 2: Content-Type is text/plain")
|
||||
(assert-contains "Content-Type" "text/plain" (get (:headers (get* base-url)) "content-type" ""))
|
||||
(println "Test 2: Content-Type is text/html")
|
||||
(assert-contains "Content-Type" "text/html" (get (:headers (get* base-url)) "content-type" ""))
|
||||
(println)
|
||||
|
||||
(println "Test 3: Root response points at the API docs")
|
||||
(println "Test 3: Root serves the HTML shell for the UI")
|
||||
(let [body (:body (get* base-url))]
|
||||
(assert-contains "Body mentions /api-docs" "/api-docs" body)
|
||||
(assert-not-empty "Body is non-empty" body)
|
||||
(println)
|
||||
(assert-contains "Body has the mount point" "<div id=\"app\"" body)
|
||||
(assert-contains "Body loads the compiled UI" "<script src=\"/js/main.js\"" body))
|
||||
(println)
|
||||
|
||||
(println "Test 4: Response is plain text, not HTML")
|
||||
(if (and (not (str/includes? body "<!DOCTYPE"))
|
||||
(not (str/includes? body "<html")))
|
||||
(do (println " ✓ Response is not HTML") (swap! pass inc))
|
||||
(do (println " ✗ Response appears to be HTML")
|
||||
(swap! fail inc)
|
||||
(swap! errors conj "Response was HTML, expected plain text"))))
|
||||
(println "Test 4: GET /js/main.js serves the compiled UI")
|
||||
(let [resp (get* (str base-url "/js/main.js"))]
|
||||
(assert-eq "HTTP status" 200 (:status resp))
|
||||
(assert-contains "Content-Type" "javascript" (get (:headers resp) "content-type" ""))
|
||||
(assert-not-empty "Body is non-empty" (:body resp))
|
||||
(assert-contains "Bundle calls the add API" "/api/add" (:body resp)))
|
||||
(println)
|
||||
|
||||
(println "Test 5: HEAD / returns 200")
|
||||
@@ -118,11 +138,102 @@
|
||||
(assert-eq "Body" {:result 5} (edn/read-string (:body resp))))
|
||||
(println)
|
||||
|
||||
(println "Test 9b: the API answers in the format the Accept header asks for, EDN by default")
|
||||
(let [json (http/get (str base-url "/api/add?x=2&y=3") {:throw false :headers {"Accept" "application/json"}})
|
||||
any (http/get (str base-url "/api/add?x=2&y=3") {:throw false :headers {"Accept" "*/*"}})
|
||||
err (http/get (str base-url "/api/todos") {:throw false :headers {"Accept" "application/json"}})]
|
||||
(assert-contains "JSON Content-Type" "application/json" (get (:headers json) "content-type" ""))
|
||||
(assert-eq "JSON body" "{\"result\":5}" (:body json))
|
||||
(assert-contains "Accept */* is EDN" "application/edn" (get (:headers any) "content-type" ""))
|
||||
(assert-contains "Errors are JSON too" "application/json" (get (:headers err) "content-type" ""))
|
||||
(assert-eq "Error body" "{\"error\":\"login required\"}" (:body err)))
|
||||
(println)
|
||||
|
||||
(println "Test 10: GET /api/add with a missing or non-numeric param returns 400")
|
||||
(assert-eq "Missing y" 400 (:status (get* (str base-url "/api/add?x=2"))))
|
||||
(assert-eq "Non-numeric x" 400 (:status (get* (str base-url "/api/add?x=abc&y=3"))))
|
||||
(println)
|
||||
|
||||
(println "Test 11: GET /auth/login redirects to Gitea's authorize page")
|
||||
(let [resp (get-no-redirect* (str base-url "/auth/login"))
|
||||
location (get (:headers resp) "location" "")]
|
||||
(assert-eq "HTTP status" 302 (:status resp))
|
||||
(assert-contains "Location" "/login/oauth/authorize?" location)
|
||||
(assert-contains "Location has the client id" "client_id=integration-client" location)
|
||||
(assert-contains "Location has a state" "state=" location)
|
||||
(assert-contains "Session cookie is HttpOnly" "HttpOnly" (str (get (:headers resp) "set-cookie" ""))))
|
||||
(println)
|
||||
|
||||
(println "Test 12: GET /auth/callback with no login in progress returns 400")
|
||||
(assert-eq "HTTP status" 400 (:status (get-no-redirect* (str base-url "/auth/callback?code=x&state=y"))))
|
||||
(println)
|
||||
|
||||
(println "Test 13: GET /auth/me without a session returns 401")
|
||||
(assert-eq "HTTP status" 401 (:status (get* (str base-url "/auth/me"))))
|
||||
(println)
|
||||
|
||||
(println "Test 14: POST /nrepl without a session returns 401 and starts nothing")
|
||||
(assert-eq "Valid body" 401 (:status (post-json* (str base-url "/nrepl") "{\"enabled\":true}")))
|
||||
(assert-eq "Invalid body (auth is checked first)" 401 (:status (post-json* (str base-url "/nrepl") "nope")))
|
||||
(assert-eq "A query-string admin flag is no bypass" 401 (:status (post-json* (str base-url "/nrepl?admin=true") "{\"enabled\":true}")))
|
||||
(println)
|
||||
|
||||
(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/3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b"))))
|
||||
(println)
|
||||
|
||||
(println "Test 16: POST /mcp without a token returns 401 pointing at the OAuth metadata")
|
||||
(let [resp (http/post (str base-url "/mcp")
|
||||
{:throw false
|
||||
:headers {"Content-Type" "application/json"
|
||||
"Accept" "application/json, text/event-stream"}
|
||||
:body "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"initialize\"}"})
|
||||
challenge (get (:headers resp) "www-authenticate" "")]
|
||||
(assert-eq "HTTP status" 401 (:status resp))
|
||||
(assert-contains "WWW-Authenticate" "Bearer resource_metadata=" challenge)
|
||||
(assert-contains "WWW-Authenticate names the metadata document" "/.well-known/oauth-protected-resource/mcp" challenge))
|
||||
(assert-eq "A bogus token is refused too" 401
|
||||
(:status (http/post (str base-url "/mcp")
|
||||
{:throw false
|
||||
:headers {"Content-Type" "application/json" "Authorization" "Bearer nope"}
|
||||
:body "{}"})))
|
||||
(println)
|
||||
|
||||
(println "Test 17: MCP OAuth discovery, registration and the authorize/token endpoints")
|
||||
(let [resource (json* (str base-url "/.well-known/oauth-protected-resource/mcp"))
|
||||
server (json* (str base-url "/.well-known/oauth-authorization-server"))]
|
||||
(assert-contains "Resource metadata names the MCP endpoint" "/mcp" (get resource "resource"))
|
||||
(assert-eq "PKCE S256 only" ["S256"] (get server "code_challenge_methods_supported"))
|
||||
(assert-contains "Registration endpoint" "/oauth/register" (get server "registration_endpoint")))
|
||||
(let [reg (http/post (str base-url "/oauth/register")
|
||||
{:throw false
|
||||
:headers {"Content-Type" "application/json"}
|
||||
:body "{\"redirect_uris\":[\"http://localhost:8123/callback\"],\"client_name\":\"integration\"}"})
|
||||
client-id (get (json/parse-string (:body reg)) "client_id")]
|
||||
(assert-eq "Registering a client" 201 (:status reg))
|
||||
(assert-eq "Registering a web redirect over plain http is refused" 400
|
||||
(:status (http/post (str base-url "/oauth/register")
|
||||
{:throw false
|
||||
:headers {"Content-Type" "application/json"}
|
||||
:body "{\"redirect_uris\":[\"http://evil.example.com/cb\"]}"})))
|
||||
(let [resp (get-no-redirect* (str base-url "/oauth/authorize?client_id=" client-id
|
||||
"&redirect_uri=http%3A%2F%2Flocalhost%3A8123%2Fcallback&response_type=code"
|
||||
"&code_challenge=E9Melhoa2OwvFrEMTJguCHaoeK1t8URWbuGJSstw-cM&code_challenge_method=S256"))]
|
||||
(assert-eq "Authorize while logged out sends the user to log in" 302 (:status resp))
|
||||
(assert-contains "Location" "/auth/login?return_to=" (get (:headers resp) "location" "")))
|
||||
(assert-eq "Authorize with an unregistered redirect URI is an error page, not a redirect" 400
|
||||
(:status (get-no-redirect* (str base-url "/oauth/authorize?client_id=" client-id
|
||||
"&redirect_uri=https%3A%2F%2Fevil.example.com%2Fcb&response_type=code"))))
|
||||
(assert-eq "A bad code is invalid_grant" "invalid_grant"
|
||||
(get (json/parse-string (:body (post-form* (str base-url "/oauth/token")
|
||||
{"grant_type" "authorization_code" "code" "nope" "client_id" client-id
|
||||
"redirect_uri" "http://localhost:8123/callback"
|
||||
"code_verifier" (apply str (repeat 43 "a"))})))
|
||||
"error")))
|
||||
(println)
|
||||
|
||||
(println "================================")
|
||||
(println (format " Results: %d passed, %d failed" @pass @fail))
|
||||
(println "================================")
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||
<title>tbd</title>
|
||||
</head>
|
||||
<body>
|
||||
<!-- The re-frame app (ui/) mounts here and replaces this placeholder. -->
|
||||
<div id="app">Loading… (if this never goes away, the UI hasn't been built: run script/ui-build)</div>
|
||||
<script src="/js/main.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
+3
-2
@@ -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
|
||||
|
||||
Executable
+20
@@ -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"
|
||||
Executable
+8
@@ -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
|
||||
@@ -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 .
|
||||
}
|
||||
|
||||
+12
-1
@@ -1,13 +1,24 @@
|
||||
#!/usr/bin/env bash
|
||||
# Start the server. Usage: script/server [port]
|
||||
# The port defaults to $PORT, then 3000.
|
||||
# The port defaults to $PORT, then 3000. Settings in .env (see .env-template) are loaded first.
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
# Load local settings (Gitea OAuth, admin users, ...) from .env; see .env-template.
|
||||
if [[ -f .env ]]; then
|
||||
set -a
|
||||
source .env
|
||||
set +a
|
||||
fi
|
||||
|
||||
port=${1:-${PORT:-3000}}
|
||||
if [[ ! $port =~ ^[0-9]+$ ]] || (( port < 1 || port > 65535 )); then
|
||||
echo "usage: script/server [port] (port must be 1-65535, got '$port')" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
if [[ ! -f resources/public/js/main.js ]]; then
|
||||
echo "note: the UI isn't built, so / will show a placeholder. Run script/ui-build first." >&2
|
||||
fi
|
||||
|
||||
PORT=$port exec clojure -X:run
|
||||
|
||||
+2
-1
@@ -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
|
||||
|
||||
Executable
+8
@@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env bash
|
||||
# Compile the re-frame UI (ui/) to resources/public/js, which the server serves at /js.
|
||||
# Needs Node and a JDK. Run this before script/server; restart isn't required afterwards.
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../ui"
|
||||
|
||||
[[ -d node_modules ]] || npm ci
|
||||
exec npx shadow-cljs release app
|
||||
Executable
+8
@@ -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
|
||||
Executable
+8
@@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env bash
|
||||
# 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 npm test
|
||||
Executable
+8
@@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env bash
|
||||
# Rebuild the UI on every change (hot reload, also serves the shadow-cljs dashboard on :9630).
|
||||
# The output lands in resources/public/js, so run script/server alongside and refresh the page.
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../ui"
|
||||
|
||||
[[ -d node_modules ]] || npm ci
|
||||
exec npx shadow-cljs watch app
|
||||
@@ -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."))
|
||||
@@ -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))}}]])
|
||||
@@ -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))}))))
|
||||
@@ -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)))
|
||||
@@ -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))
|
||||
@@ -0,0 +1,143 @@
|
||||
(ns tbd.auth.core
|
||||
"Gitea OAuth2 (authorization-code flow) and the admin allowlist. No Ring here; the
|
||||
routes and middleware own that."
|
||||
(:require [clojure.string :as str]
|
||||
[muuntaja.core :as m])
|
||||
(:import (java.net URI URLEncoder)
|
||||
(java.net.http HttpClient HttpRequest HttpResponse$BodyHandlers HttpRequest$BodyPublishers)
|
||||
(java.nio.charset StandardCharsets)
|
||||
(java.security MessageDigest SecureRandom)
|
||||
(java.time Duration)
|
||||
(java.util Base64)))
|
||||
|
||||
(def ^:private http-client
|
||||
(delay (-> (HttpClient/newBuilder) (.connectTimeout (Duration/ofSeconds 5)) .build)))
|
||||
|
||||
(defn java-http
|
||||
"Default `:http` fn: {:method :get|:post, :url, :headers, :body} -> {:status, :body}.
|
||||
Configs can swap it out, which is how the tests stub Gitea."
|
||||
[{:keys [method url headers body]}]
|
||||
(let [builder (-> (HttpRequest/newBuilder (URI/create url)) (.timeout (Duration/ofSeconds 10)))]
|
||||
(doseq [[k v] headers] (.header builder k v))
|
||||
(case method
|
||||
:get (.GET builder)
|
||||
:post (.POST builder (HttpRequest$BodyPublishers/ofString body)))
|
||||
(let [resp (.send ^HttpClient @http-client (.build builder) (HttpResponse$BodyHandlers/ofString))]
|
||||
{:status (.statusCode resp) :body (.body resp)})))
|
||||
|
||||
(defn- env-val [env k]
|
||||
(let [v (get env k)]
|
||||
(when-not (str/blank? v) (str/trim v))))
|
||||
|
||||
(defn- strip-trailing-slashes [s]
|
||||
(some-> s (str/replace #"/+$" "")))
|
||||
|
||||
(defn env-config
|
||||
"Auth config from environment variables:
|
||||
GITEA_URL, GITEA_CLIENT_ID, GITEA_CLIENT_SECRET the Gitea OAuth2 application
|
||||
BASE_URL public URL of this app; <BASE_URL>/auth/callback is the redirect URI to register in Gitea,
|
||||
and it is the issuer/resource URL the MCP OAuth endpoints advertise
|
||||
ADMIN_USERS comma-separated Gitea usernames allowed to use the admin API (none by default)
|
||||
SESSION_SECRET signs/encrypts session cookies (random per start when unset, so logins don't survive restarts)"
|
||||
([] (env-config (System/getenv)))
|
||||
([env]
|
||||
(let [base-url (strip-trailing-slashes (env-val env "BASE_URL"))]
|
||||
{:base-url base-url
|
||||
:gitea-url (strip-trailing-slashes (env-val env "GITEA_URL"))
|
||||
:client-id (env-val env "GITEA_CLIENT_ID")
|
||||
:client-secret (env-val env "GITEA_CLIENT_SECRET")
|
||||
:redirect-uri (some-> base-url (str "/auth/callback"))
|
||||
:secure-cookies? (boolean (some-> base-url (str/starts-with? "https://")))
|
||||
:admin-users (->> (str/split (or (env-val env "ADMIN_USERS") "") #",")
|
||||
(map str/trim)
|
||||
(remove str/blank?)
|
||||
(map str/lower-case)
|
||||
set)
|
||||
:session-secret (env-val env "SESSION_SECRET")
|
||||
:http java-http})))
|
||||
|
||||
(defn configured?
|
||||
"True when everything needed to run the OAuth flow is set."
|
||||
[config]
|
||||
(every? config [:gitea-url :client-id :client-secret :redirect-uri]))
|
||||
|
||||
(defn admin?
|
||||
"Gitea usernames are case-insensitive, so the allowlist is compared lower-cased."
|
||||
[config login]
|
||||
(contains? (:admin-users config) (str/lower-case login)))
|
||||
|
||||
(defn session-key
|
||||
"Cookie stores need a 16-byte key; derive it from the secret, or make a throwaway one."
|
||||
[secret]
|
||||
(if secret
|
||||
(byte-array (take 16 (.digest (MessageDigest/getInstance "SHA-256")
|
||||
(.getBytes ^String secret StandardCharsets/UTF_8))))
|
||||
(let [k (byte-array 16)]
|
||||
(.nextBytes (SecureRandom.) k)
|
||||
k)))
|
||||
|
||||
(defn new-state
|
||||
"Random OAuth `state`, tying the callback to the browser that started the login."
|
||||
[]
|
||||
(let [bytes (byte-array 32)]
|
||||
(.nextBytes (SecureRandom.) bytes)
|
||||
(.encodeToString (.withoutPadding (Base64/getUrlEncoder)) bytes)))
|
||||
|
||||
(defn state-matches? [expected actual]
|
||||
(and (string? expected)
|
||||
(string? actual)
|
||||
(MessageDigest/isEqual (.getBytes ^String expected StandardCharsets/UTF_8)
|
||||
(.getBytes ^String actual StandardCharsets/UTF_8))))
|
||||
|
||||
(defn form-encode
|
||||
"Params as an `application/x-www-form-urlencoded` string (also the format of a URL query)."
|
||||
[params]
|
||||
(str/join "&" (map (fn [[k v]]
|
||||
(str (URLEncoder/encode (name k) StandardCharsets/UTF_8) "="
|
||||
(URLEncoder/encode (str v) StandardCharsets/UTF_8)))
|
||||
params)))
|
||||
|
||||
(defn safe-return-to
|
||||
"`path` if it is a local path a login can send the browser back to, else nil. It must start
|
||||
with a single `/` (so not `//host` or `/\\host`, which browsers read as another site)."
|
||||
[path]
|
||||
(when (and (string? path)
|
||||
(<= (count path) 2000)
|
||||
(re-matches #"/(?:[^/\\\s][^\\\s]*)?" path))
|
||||
path))
|
||||
|
||||
(defn authorize-url [{:keys [gitea-url client-id redirect-uri]} state]
|
||||
(str gitea-url "/login/oauth/authorize?"
|
||||
(form-encode {:client_id client-id
|
||||
:redirect_uri redirect-uri
|
||||
:response_type "code"
|
||||
:state state})))
|
||||
|
||||
(defn- parse-json [body]
|
||||
(m/decode "application/json" body))
|
||||
|
||||
(defn exchange-code
|
||||
"Trades the authorization code for an access token; nil if Gitea refuses it."
|
||||
[{:keys [gitea-url client-id client-secret redirect-uri http]} code]
|
||||
(let [{:keys [status body]} (http {:method :post
|
||||
:url (str gitea-url "/login/oauth/access_token")
|
||||
:headers {"Content-Type" "application/x-www-form-urlencoded"
|
||||
"Accept" "application/json"}
|
||||
:body (form-encode {:grant_type "authorization_code"
|
||||
:client_id client-id
|
||||
:client_secret client-secret
|
||||
:redirect_uri redirect-uri
|
||||
:code code})})]
|
||||
(when (= 200 status)
|
||||
(:access_token (parse-json body)))))
|
||||
|
||||
(defn fetch-user
|
||||
"The Gitea user behind an access token as {:login :id}; nil if Gitea refuses the token."
|
||||
[{:keys [gitea-url http]} token]
|
||||
(let [{:keys [status body]} (http {:method :get
|
||||
:url (str gitea-url "/api/v1/user")
|
||||
:headers {"Authorization" (str "Bearer " token)
|
||||
"Accept" "application/json"}})]
|
||||
(when (= 200 status)
|
||||
(let [{:keys [login id]} (parse-json body)]
|
||||
(when login {:login login :id id})))))
|
||||
@@ -0,0 +1,57 @@
|
||||
(ns tbd.auth.middleware
|
||||
(:require [ring.middleware.session :refer [wrap-session]]
|
||||
[ring.middleware.session.cookie :refer [cookie-store]]
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.http :refer [respond]]))
|
||||
|
||||
(def session-ttl-ms (* 8 60 60 1000))
|
||||
|
||||
(defn session-middleware
|
||||
"Cookie-backed sessions (encrypted and signed, so nothing is stored server-side). Lax, not
|
||||
Strict: the OAuth callback is a cross-site redirect from Gitea and must still carry the
|
||||
cookie that holds the login `state`."
|
||||
[handler config]
|
||||
(wrap-session handler {:store (cookie-store {:key (auth/session-key (:session-secret config))})
|
||||
:cookie-name "tbd-session"
|
||||
:cookie-attrs {:http-only true
|
||||
:same-site :lax
|
||||
:secure (:secure-cookies? config)
|
||||
:max-age (quot session-ttl-ms 1000)}}))
|
||||
|
||||
(defn current-user
|
||||
"The logged-in user from the session, or nil when there is none or it has expired. The
|
||||
cookie is only a bearer of `:expires-at`, so the server enforces the lifetime here."
|
||||
([req] (current-user req (System/currentTimeMillis)))
|
||||
([req now]
|
||||
(let [{:keys [expires-at] :as user} (get-in req [:session :user])]
|
||||
(when (and user expires-at (< now expires-at))
|
||||
user))))
|
||||
|
||||
(defn admin-middleware
|
||||
"Reitit middleware for routes whose data has `:admin? true`: 401 without a login, 403 when
|
||||
the user isn't on the ADMIN_USERS allowlist. Passes the user on as `:user`. Mount it ahead
|
||||
of the parsing/coercion middleware so unauthenticated callers never reach them."
|
||||
[config]
|
||||
{:name ::admin
|
||||
:compile (fn [route-data _opts]
|
||||
(when (:admin? route-data)
|
||||
(fn [handler]
|
||||
(fn [req]
|
||||
(if-let [user (current-user req)]
|
||||
(if (auth/admin? config (:login user))
|
||||
(handler (assoc req :user user))
|
||||
(respond 403 {:error "admin access required"}))
|
||||
(respond 401 {:error "login required"}))))))})
|
||||
|
||||
(def login-middleware
|
||||
"Reitit middleware for routes whose data has `:login? true`: 401 without a login, otherwise
|
||||
the user goes on as `:user` ({:login :id ...}). Like admin-middleware, mount it ahead of the
|
||||
parsing/coercion middleware."
|
||||
{:name ::login
|
||||
:compile (fn [route-data _opts]
|
||||
(when (:login? route-data)
|
||||
(fn [handler]
|
||||
(fn [req]
|
||||
(if-let [user (current-user req)]
|
||||
(handler (assoc req :user user))
|
||||
(respond 401 {:error "login required"}))))))})
|
||||
@@ -0,0 +1,66 @@
|
||||
(ns tbd.auth.routes
|
||||
(:require [ring.util.response :as response]
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.auth.middleware :as mw]
|
||||
[tbd.http :refer [respond]]))
|
||||
|
||||
(def ^:private not-configured
|
||||
(respond 503 {:error "OAuth is not configured (set GITEA_URL, GITEA_CLIENT_ID, GITEA_CLIENT_SECRET, BASE_URL)"}))
|
||||
|
||||
(defn- login-handler [config]
|
||||
(fn [{:keys [session parameters]}]
|
||||
(if-not (auth/configured? config)
|
||||
not-configured
|
||||
(let [state (auth/new-state)
|
||||
return-to (auth/safe-return-to (get-in parameters [:query :return_to]))]
|
||||
(-> (response/redirect (auth/authorize-url config state))
|
||||
(assoc :session (cond-> (assoc session :oauth-state state)
|
||||
return-to (assoc :return-to return-to))))))))
|
||||
|
||||
(defn- callback-handler [config]
|
||||
(fn [{:keys [session parameters]}]
|
||||
(let [{:keys [code state error]} (:query parameters)]
|
||||
(cond
|
||||
(not (auth/configured? config)) not-configured
|
||||
(not (auth/state-matches? (:oauth-state session) state)) (respond 400 {:error "invalid OAuth state"})
|
||||
error (respond 403 {:error "login was denied"})
|
||||
(nil? code) (respond 400 {:error "missing authorization code"})
|
||||
:else
|
||||
(try
|
||||
(let [user (some->> (auth/exchange-code config code) (auth/fetch-user config))]
|
||||
(if user
|
||||
;; A fresh session (not the old one plus a user) so nothing from before login carries over.
|
||||
(-> (response/redirect (or (auth/safe-return-to (:return-to session)) "/"))
|
||||
(assoc :session {:user (assoc user :expires-at (+ (System/currentTimeMillis)
|
||||
mw/session-ttl-ms))}))
|
||||
(respond 401 {:error "login failed"})))
|
||||
(catch Exception e
|
||||
(println "[tbd] Gitea login failed:" (.getMessage e))
|
||||
(respond 502 {:error "could not complete login with Gitea"})))))))
|
||||
|
||||
(defn- me-handler [config]
|
||||
(fn [req]
|
||||
(if-let [{:keys [login id]} (mw/current-user req)]
|
||||
(respond 200 {:login login :id id :admin? (auth/admin? config login)})
|
||||
(respond 401 {:error "login required"}))))
|
||||
|
||||
(defn routes [config]
|
||||
["/auth"
|
||||
["/login" {:get {:tags ["auth"]
|
||||
:summary "Start the Gitea OAuth login (redirects to Gitea); afterwards the browser goes to `return_to` (a local path) or /"
|
||||
:parameters {:query [:map [:return_to {:optional true} :string]]}
|
||||
:handler (login-handler config)}}]
|
||||
["/callback" {:get {:tags ["auth"]
|
||||
:summary "OAuth redirect target; completes the login and redirects to / (or the login's return_to)"
|
||||
:parameters {:query [:map
|
||||
[:code {:optional true} :string]
|
||||
[:state {:optional true} :string]
|
||||
[:error {:optional true} :string]]}
|
||||
:handler (callback-handler config)}}]
|
||||
["/logout" {:post {:tags ["auth"]
|
||||
:summary "End the session"
|
||||
:handler (fn [_req]
|
||||
(assoc (respond 200 {:logged-out true}) :session nil))}}]
|
||||
["/me" {:get {:tags ["auth"]
|
||||
:summary "The logged-in user (401 if not logged in)"
|
||||
:handler (me-handler config)}}]])
|
||||
@@ -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]))
|
||||
@@ -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)}}]]])
|
||||
@@ -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))
|
||||
@@ -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)))))))))
|
||||
+113
-20
@@ -1,14 +1,37 @@
|
||||
(ns tbd.core
|
||||
(:require [ring.adapter.jetty :as jetty]
|
||||
(:require [clojure.string :as str]
|
||||
[ring.adapter.jetty :as jetty]
|
||||
[ring.middleware.defaults :refer [wrap-defaults api-defaults]]
|
||||
[ring.middleware.head :refer [wrap-head]]
|
||||
[reitit.ring :as ring]
|
||||
[reitit.swagger :as swagger]
|
||||
[reitit.swagger-ui :as swagger-ui]
|
||||
[reitit.coercion]
|
||||
[reitit.coercion.malli :as malli]
|
||||
[reitit.ring.coercion :as coercion]
|
||||
[reitit.ring.middleware.exception :as exception]
|
||||
[reitit.ring.middleware.muuntaja :as muuntaja-middleware]
|
||||
[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.math.routes :as math]))
|
||||
[tbd.http :as http]
|
||||
[tbd.math.routes :as math]
|
||||
[tbd.mcp.routes :as mcp-routes]
|
||||
[tbd.nrepl.core :as nrepl]
|
||||
[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]))
|
||||
|
||||
(defn- swagger-handler
|
||||
"reitit emits `\"definitions\": null` when no route declares a schema, which
|
||||
@@ -21,31 +44,91 @@
|
||||
(and (map? (:body resp)) (nil? (:definitions (:body resp))))
|
||||
(update :body dissoc :definitions))))))
|
||||
|
||||
(defn- coercion-error-handler
|
||||
"Invalid request params -> 400, in the same shape (and format) the routes use."
|
||||
[e _req]
|
||||
(http/respond 400 {:error "invalid request parameters"
|
||||
:details (:humanized (reitit.coercion/encode-error (ex-data e)))}))
|
||||
|
||||
(defn- index-handler
|
||||
"The HTML shell for the re-frame UI (ui/); it loads the compiled JS from /js. With a WebMCP
|
||||
origin-trial token it also sends it as an `Origin-Trial` header, which is how Chrome enables the
|
||||
trial for this origin before any script runs."
|
||||
[{:keys [origin-trial-token]}]
|
||||
(fn [_req]
|
||||
(cond-> (-> (response/resource-response "public/index.html")
|
||||
(response/content-type "text/html; charset=utf-8"))
|
||||
(seq origin-trial-token) (response/header "Origin-Trial" origin-trial-token))))
|
||||
|
||||
(defn- decode-error-handler
|
||||
"A request body that isn't valid for its Content-Type -> 400, in the same shape (and format) the routes use."
|
||||
[_e _req]
|
||||
(http/respond 400 {:error "malformed request body"}))
|
||||
|
||||
(def ^:private exception-middleware
|
||||
(exception/create-exception-middleware
|
||||
(assoc exception/default-handlers
|
||||
:reitit.coercion/request-coercion coercion-error-handler
|
||||
:muuntaja/decode decode-error-handler)))
|
||||
|
||||
;; Each logical group (health, users, orders, ...) owns a `tbd.<group>.routes`
|
||||
;; namespace that returns its own route subtree; they're concatenated here.
|
||||
(def router
|
||||
(ring/router
|
||||
[["/swagger.json"
|
||||
{:get {:no-doc true
|
||||
:swagger {:info {:title "tbd API" :version "1.0.0"}}
|
||||
:handler (swagger-handler)}}]
|
||||
["/" {:get {:no-doc true
|
||||
:handler (fn [_req]
|
||||
{:status 200
|
||||
:headers {"Content-Type" "text/plain; charset=utf-8"}
|
||||
:body "tbd API — see /api-docs for documentation, /swagger.json for the spec"})}}]
|
||||
(health/routes)
|
||||
(math/routes)]
|
||||
{:data {:muuntaja m/instance
|
||||
:middleware [muuntaja-middleware/format-middleware]}}))
|
||||
(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).
|
||||
{:muuntaja m/instance
|
||||
:get {:no-doc true
|
||||
:swagger {:info {:title "tbd API" :version "1.0.0"}}
|
||||
:handler (swagger-handler)}}]
|
||||
["/" {:get {:no-doc true
|
||||
:handler (index-handler webmcp)}}]
|
||||
(health/routes)
|
||||
(math/routes)
|
||||
(mcp-routes/routes auth ds)
|
||||
(a2a/routes auth ds chat)
|
||||
(oauth-routes/routes auth ds)
|
||||
(auth-routes/routes auth)
|
||||
(chat-routes/routes chat ds)
|
||||
(nrepl-routes/routes nrepl)
|
||||
(todo-routes/routes ds)]
|
||||
{:data {:muuntaja http/muuntaja
|
||||
:coercion malli/coercion
|
||||
;; 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)
|
||||
auth-mw/login-middleware
|
||||
parameters/parameters-middleware
|
||||
exception-middleware
|
||||
muuntaja-middleware/format-request-middleware
|
||||
coercion/coerce-request-middleware]}})))
|
||||
|
||||
(def app
|
||||
(defn make-app [{:keys [auth] :as config}]
|
||||
(-> (ring/ring-handler
|
||||
router
|
||||
(make-router config)
|
||||
(ring/routes
|
||||
(swagger-ui/create-swagger-ui-handler {:path "/api-docs"})
|
||||
;; Compiled UI (script/ui-build writes resources/public/js).
|
||||
(ring/create-resource-handler {:path "/js" :root "public/js"})
|
||||
(ring/create-default-handler)))
|
||||
wrap-head))
|
||||
wrap-head
|
||||
http/wrap-browser-viewable-edn
|
||||
(auth-mw/session-middleware auth)))
|
||||
|
||||
(def config
|
||||
{:auth (auth/env-config)
|
||||
:nrepl (nrepl/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))
|
||||
|
||||
(defn add-shutdown-hook [server]
|
||||
(.addShutdownHook
|
||||
@@ -56,6 +139,16 @@
|
||||
(let [port (Integer/parseInt (str (or (System/getenv "PORT")
|
||||
(get opts :port 3000))))]
|
||||
(println (format "[tbd] starting server on port %d..." port))
|
||||
(when-not (auth/configured? (:auth config))
|
||||
(println "[tbd] WARNING: Gitea OAuth is not configured; login, the admin API and the MCP endpoint are unavailable"))
|
||||
(when (empty? (get-in config [:auth :admin-users]))
|
||||
(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
|
||||
|
||||
@@ -0,0 +1,31 @@
|
||||
(ns tbd.http
|
||||
(:require [muuntaja.core :as m]))
|
||||
|
||||
(def muuntaja
|
||||
"Content negotiation for the API. The request body is decoded by its Content-Type and the
|
||||
response is encoded by the Accept header: JSON, EDN or Transit. When a request doesn't say
|
||||
(no Content-Type, no Accept, or an Accept nothing here satisfies, like `*/*`) it is EDN."
|
||||
(m/create
|
||||
(-> m/default-options
|
||||
(assoc :default-format "application/edn")
|
||||
(assoc-in [:http :extract-content-type]
|
||||
#(or (m/extract-content-type-ring %) "application/edn")))))
|
||||
|
||||
(defn respond
|
||||
"A response whose `body` is plain data; the muuntaja middleware encodes it as the client asked."
|
||||
[status body]
|
||||
{:status status :body body})
|
||||
|
||||
(defn wrap-browser-viewable-edn
|
||||
"Browsers download `application/edn` instead of showing it. When the request comes from a
|
||||
browser navigation (Accept includes text/html), relabel EDN responses as text/plain so they
|
||||
render inline. Programmatic clients (fetch, curl, ...) still get `application/edn`."
|
||||
[handler]
|
||||
(fn [req]
|
||||
(let [resp (handler req)
|
||||
accept (get-in req [:headers "accept"] "")
|
||||
content-type (get-in resp [:headers "Content-Type"] "")]
|
||||
(if (and (re-find #"text/html" accept)
|
||||
(.startsWith ^String content-type "application/edn"))
|
||||
(assoc-in resp [:headers "Content-Type"] "text/plain; charset=utf-8")
|
||||
resp))))
|
||||
+6
-16
@@ -1,24 +1,14 @@
|
||||
(ns tbd.math.routes
|
||||
(:require [tbd.math.core :as math]))
|
||||
(:require [tbd.http :as http]
|
||||
[tbd.math.core :as math]
|
||||
[tbd.math.schema :as schema]))
|
||||
|
||||
(defn- parse-num [s]
|
||||
(when s
|
||||
(or (parse-long s) (parse-double s))))
|
||||
|
||||
(defn- edn-response [status body]
|
||||
{:status status
|
||||
:headers {"Content-Type" "application/edn; charset=utf-8"}
|
||||
:body (pr-str body)})
|
||||
|
||||
(defn- add-handler [{:keys [query-params]}]
|
||||
(let [x (parse-num (get query-params "x"))
|
||||
y (parse-num (get query-params "y"))]
|
||||
(if (and x y)
|
||||
(edn-response 200 {:result (math/add x y)})
|
||||
(edn-response 400 {:error "x and y query params are required and must be numbers"}))))
|
||||
(defn- add-handler [{{{:keys [x y]} :query} :parameters}]
|
||||
(http/respond 200 {:result (math/add x y)}))
|
||||
|
||||
(defn routes []
|
||||
["/api/add"
|
||||
{:get {:tags ["math"]
|
||||
:summary "Add two numbers (?x=2&y=3 => {:result 5})"
|
||||
:parameters {:query schema/Add}
|
||||
:handler add-handler}}])
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
(ns tbd.math.schema
|
||||
"The shapes of the math group's data, as Malli schemas. This is the one definition of them:
|
||||
the HTTP routes coerce and validate requests with it (tbd.math.routes), and the MCP tools
|
||||
derive their input schema and validate their arguments from it (tbd.mcp.tools).")
|
||||
|
||||
(defn- number [description]
|
||||
;; :int first so \"2\" stays a long (a bare `number?` or :double would decode it to 2.0).
|
||||
;; The :swagger/* and :json-schema/* props make the generated specs say plain `number`
|
||||
;; instead of the first :or branch.
|
||||
[:or {:description description
|
||||
:swagger/type "number" :swagger/format "double"
|
||||
:json-schema/type "number" :json-schema/format "double"}
|
||||
:int :double])
|
||||
|
||||
(def Add
|
||||
"The two addends."
|
||||
[:map
|
||||
[:x (number "First addend")]
|
||||
[:y (number "Second addend")]])
|
||||
@@ -0,0 +1,51 @@
|
||||
(ns tbd.mcp.routes
|
||||
"The MCP server, run as part of this server: plumcp's Streamable HTTP transport as a Ring
|
||||
handler mounted at `/mcp`. Point an MCP client at <BASE_URL>/mcp. The tools it offers are in
|
||||
tbd.mcp.tools. Every request needs an OAuth access token from tbd's own authorization server
|
||||
(tbd.oauth.routes); tbd.oauth.middleware checks it and tells the tools who is calling."
|
||||
(:require [plumcp.core.api.entity-support :as es]
|
||||
[plumcp.core.deps.runtime :as rt]
|
||||
[plumcp.core.server.http-ring :as mcp-http]
|
||||
[plumcp.core.server.server-support :as mcp-server]
|
||||
[plumcp.core.support.traffic-logger :as traffic-logger]
|
||||
[tbd.mcp.tools :as tools]
|
||||
[tbd.oauth.middleware :as oauth-mw]))
|
||||
|
||||
(defn- wrap-runtime
|
||||
"`handler` with `bindings` added to the plumcp runtime bag of every request, for the tools to use."
|
||||
[handler bindings]
|
||||
(fn [req] (handler (rt/upsert-runtime req bindings))))
|
||||
|
||||
(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 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]
|
||||
(let [{:keys [runtime jsonrpc-handler] :as options}
|
||||
(mcp-server/make-server-options
|
||||
{:info (es/make-info "tbd" "1.0.0" "tbd MCP server")
|
||||
:primitives tools/primitives
|
||||
;; The default logs every MCP message to stderr; it's noise (and tool arguments).
|
||||
: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/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]
|
||||
(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
|
||||
;; drops the router-wide :middleware for this route instead of adding to it.
|
||||
{:middleware ^:replace []
|
||||
:no-doc true
|
||||
;; No :get on purpose. That is MCP's optional server-to-client SSE stream, and the spec lets
|
||||
;; a server answer it with 405. Under Jetty it would also hang: the response headers aren't
|
||||
;; sent until the first event, and every open stream holds a thread. None of the tools push
|
||||
;; anything, so nothing is lost. Add :get here if one ever needs to (and test it against Jetty).
|
||||
:post {:handler handler}
|
||||
:delete {:handler handler}}]))
|
||||
@@ -0,0 +1,40 @@
|
||||
(ns tbd.mcp.schema
|
||||
"MCP tools defined from Malli schemas, the same ones the HTTP routes use (tbd.<group>.schema),
|
||||
so a shape of data is written down once. A schema gives the tool its JSON-Schema input schema
|
||||
(what clients and models see) and coerces and validates the arguments it is called with. plumcp
|
||||
itself only checks that required arguments are present."
|
||||
(:require [malli.core :as m]
|
||||
[malli.error :as me]
|
||||
[malli.json-schema :as json-schema]
|
||||
[malli.transform :as mt]
|
||||
[plumcp.core.api.capability :as cap]
|
||||
[plumcp.core.deps.runtime :as rt]))
|
||||
|
||||
(def ^:private transformer
|
||||
;; Unknown arguments are dropped, and JSON values become what the schema says (keywords, ...).
|
||||
(mt/transformer mt/strip-extra-keys-transformer mt/json-transformer))
|
||||
|
||||
(defn coerce!
|
||||
"`args` decoded for `schema`, or an exception whose message says what is wrong with them
|
||||
(an exception in a tool is an error result the model can read)."
|
||||
[schema args]
|
||||
(let [decoded (m/decode schema args transformer)]
|
||||
(if (m/validate schema decoded)
|
||||
decoded
|
||||
(throw (ex-info (str "invalid arguments: " (pr-str (me/humanize (m/explain schema decoded))))
|
||||
{})))))
|
||||
|
||||
(defn tool
|
||||
"A tool for plumcp's `:primitives` `:tools`. `schema` is a `:map` schema of its arguments; `f` is
|
||||
called with them, coerced and validated, and with the request's plumcp runtime bag (`ctx`, where
|
||||
tbd.mcp.routes and tbd.oauth.middleware put what tools need: read it with `ctx-get`). It returns a
|
||||
string, number, boolean or vector of content, or throws."
|
||||
[tool-name description schema f]
|
||||
(cap/make-tool-item tool-name (json-schema/transform schema)
|
||||
(fn [args] (f (coerce! schema (dissoc args rt/k-runtime)) args))
|
||||
:description description))
|
||||
|
||||
(defn ctx-get
|
||||
"`k` from the runtime bag `ctx`; throws if it is missing (a bug, not something to run without)."
|
||||
[ctx k]
|
||||
(rt/!>get ctx k))
|
||||
@@ -0,0 +1,74 @@
|
||||
(ns tbd.mcp.tools
|
||||
"The MCP tools the server offers, in the shape plumcp's server options take as `:primitives`.
|
||||
Like the HTTP handlers, a tool is a thin adapter over a group's business logic: pure functions
|
||||
(tbd.<group>.core) or, for a group with storage, its service (tbd.<group>.service), which the
|
||||
HTTP routes call too. A tool has no rules of its own and never touches a database. Its
|
||||
arguments are described by the group's Malli schema (tbd.<group>.schema), the same one the HTTP
|
||||
routes use, so shapes are defined once and every tool gets its input schema and argument
|
||||
validation from them (see tbd.mcp.schema).
|
||||
|
||||
A tool function takes the coerced arguments and the request context, and returns a string,
|
||||
number, boolean or vector of content, or throws: an exception becomes an error result the model
|
||||
can read, not a failed request."
|
||||
(:require [muuntaja.core :as m]
|
||||
[tbd.math.core :as math]
|
||||
[tbd.math.schema :as math-schema]
|
||||
[tbd.mcp.schema :refer [tool ctx-get]]
|
||||
[tbd.oauth.middleware :as oauth-mw]
|
||||
[tbd.todo.schema :as todo-schema]
|
||||
[tbd.todo.service :as todo]))
|
||||
|
||||
(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
|
||||
carried (see tbd.oauth.middleware). Tools that touch a user's data go through this, and
|
||||
check `:admin?` for anything admin-only. Throws if there is none (the transport never lets
|
||||
such a request through, so that would be a bug, and no tool should run as nobody)."
|
||||
[ctx]
|
||||
(ctx-get ctx (oauth-mw/user-key)))
|
||||
|
||||
(defn- ->json [data] (slurp (m/encode "application/json" data)))
|
||||
|
||||
(defn- ok!
|
||||
"The value of a service result, or throws its error (which reaches the model as an error result)."
|
||||
[{:keys [ok error]}]
|
||||
(if error (throw (ex-info error {})) ok))
|
||||
|
||||
;; Todos belong to the caller, and tbd.todo.service scopes every operation to them.
|
||||
(defn- ds [ctx] (ctx-get ctx ds-key))
|
||||
|
||||
(def primitives
|
||||
{:tools
|
||||
[(tool "ping" "Health check: returns pong" [:map]
|
||||
(fn [_ _] "pong"))
|
||||
|
||||
(tool "add" "Add two numbers" math-schema/Add
|
||||
(fn [{:keys [x y]} _] (math/add x y)))
|
||||
|
||||
(tool "whoami" "Says which user this connection acts as, and whether they are an admin" [:map]
|
||||
(fn [_ ctx]
|
||||
(let [{:keys [login id admin?]} (current-user ctx)]
|
||||
(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 (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 (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! (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! (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! (ds ctx) (current-user ctx) id))
|
||||
"deleted"))]})
|
||||
@@ -0,0 +1,67 @@
|
||||
(ns tbd.nrepl.core
|
||||
"The on-demand nREPL debug server. No HTTP here."
|
||||
(:require [clojure.string :as str]
|
||||
[nrepl.server :as nrepl])
|
||||
(:import (java.net InetAddress InetSocketAddress Socket)))
|
||||
|
||||
(def default-port 7888)
|
||||
|
||||
;; nREPL has no authentication and evaluates arbitrary code, so it only listens on loopback
|
||||
;; unless the operator explicitly opens it up.
|
||||
(def default-bind "127.0.0.1")
|
||||
|
||||
(defn env-config
|
||||
"NREPL_PORT (default 7888) and NREPL_BIND (default 127.0.0.1)."
|
||||
([] (env-config (System/getenv)))
|
||||
([env]
|
||||
(let [port (get env "NREPL_PORT")
|
||||
bind (get env "NREPL_BIND")]
|
||||
{:port (if (str/blank? port) default-port (parse-long (str/trim port)))
|
||||
:bind (if (str/blank? bind) default-bind (str/trim bind))})))
|
||||
|
||||
(defonce ^:private state (atom nil))
|
||||
|
||||
(defn status []
|
||||
(if-let [{:keys [port bind]} @state]
|
||||
{:enabled true :bind bind :port port}
|
||||
{:enabled false}))
|
||||
|
||||
(defn enable!
|
||||
"Starts the server if it isn't running (a no-op otherwise); returns the status. Port 0
|
||||
picks a free port, and the status reports the one actually bound."
|
||||
[{:keys [port bind]}]
|
||||
(locking state
|
||||
(when-not @state
|
||||
(let [server (nrepl/start-server :port port :bind bind)]
|
||||
(reset! state {:server server :bind bind :port (:port server)})))
|
||||
(status)))
|
||||
|
||||
(defn- accepting?
|
||||
"True if something takes connections on `bind`:`port` (a wildcard bind is probed via loopback)."
|
||||
[bind port]
|
||||
(let [addr (InetAddress/getByName bind)
|
||||
addr (if (.isAnyLocalAddress addr) (InetAddress/getLoopbackAddress) addr)]
|
||||
(try (with-open [s (Socket.)]
|
||||
(.connect s (InetSocketAddress. addr (int port)) 200)
|
||||
true)
|
||||
(catch java.io.IOException _ false))))
|
||||
|
||||
(defn- await-closed
|
||||
"Blocks until `bind`:`port` refuses connections, for up to two seconds. Closing a server socket
|
||||
doesn't stop the kernel queueing connections while the accept loop is still blocked in accept(),
|
||||
so for a moment after `stop-server` the port can still be connected to."
|
||||
[bind port]
|
||||
(let [deadline (+ (System/nanoTime) 2000000000)]
|
||||
(while (and (accepting? bind port) (< (System/nanoTime) deadline))
|
||||
(Thread/sleep 5))))
|
||||
|
||||
(defn disable!
|
||||
"Stops the server if it's running, and returns once its port really refuses connections;
|
||||
returns the status."
|
||||
[]
|
||||
(locking state
|
||||
(when-let [{:keys [server bind port]} @state]
|
||||
(nrepl/stop-server server)
|
||||
(await-closed bind port)
|
||||
(reset! state nil))
|
||||
(status)))
|
||||
@@ -0,0 +1,31 @@
|
||||
(ns tbd.nrepl.routes
|
||||
(:require [tbd.http :refer [respond]]
|
||||
[tbd.nrepl.core :as nrepl]))
|
||||
|
||||
(defn- toggle-handler [config]
|
||||
(fn [{{{:keys [enabled]} :body} :parameters {:keys [login]} :user}]
|
||||
(try
|
||||
(let [status (if enabled (nrepl/enable! config) (nrepl/disable!))]
|
||||
(println (format "[tbd] nREPL %s by %s%s"
|
||||
(if enabled "enabled" "disabled")
|
||||
login
|
||||
(if enabled (format " on %s:%d" (:bind status) (:port status)) "")))
|
||||
(respond 200 status))
|
||||
(catch Exception e
|
||||
(println "[tbd] nREPL toggle failed:" (.getMessage e))
|
||||
(respond 500 {:error (str "could not change nREPL state: " (.getMessage e))})))))
|
||||
|
||||
(defn- status-handler [_req]
|
||||
(respond 200 (nrepl/status)))
|
||||
|
||||
(defn routes [config]
|
||||
["/nrepl"
|
||||
{:get {:tags ["admin"]
|
||||
:summary "Read whether the nREPL debug server is on or off (admin only)"
|
||||
:admin? true
|
||||
:handler status-handler}
|
||||
:post {:tags ["admin"]
|
||||
:summary "Enable or disable the nREPL debug server (admin only)"
|
||||
:admin? true
|
||||
:parameters {:body [:map [:enabled {:description "true starts the server, false stops it"} :boolean]]}
|
||||
:handler (toggle-handler config)}}])
|
||||
@@ -0,0 +1,144 @@
|
||||
(ns tbd.oauth.core
|
||||
"The rules of tbd's own OAuth 2.1 authorization server, which is how MCP clients get a token
|
||||
for /mcp: PKCE, redirect URI checks, scopes, the metadata documents clients discover it by,
|
||||
and token generation. No Ring and no SQL here; tbd.oauth.routes and tbd.oauth.db own those.
|
||||
Users prove who they are with the Gitea login (tbd.auth); the tokens issued here are tbd's
|
||||
own, and Gitea's never leave the login step."
|
||||
(:require [clojure.string :as str]
|
||||
[tbd.auth.core :as auth])
|
||||
(:import (java.net URI URISyntaxException)
|
||||
(java.nio.charset StandardCharsets)
|
||||
(java.security MessageDigest SecureRandom)
|
||||
(java.util Base64 HexFormat)))
|
||||
|
||||
(def scope "The only scope: use the MCP server as yourself." "mcp")
|
||||
|
||||
(def code-ttl-ms "An authorization code must be traded for tokens within a minute." (* 60 1000))
|
||||
(def access-ttl-ms (* 60 60 1000))
|
||||
(def refresh-ttl-ms (* 30 24 60 60 1000))
|
||||
|
||||
(defn resource-url
|
||||
"The MCP endpoint, which is the OAuth `resource` tokens are issued for."
|
||||
[base-url]
|
||||
(str base-url "/mcp"))
|
||||
|
||||
(defn protected-resource-metadata
|
||||
"RFC 9728: tells a client that /mcp wants tokens and which authorization server issues them."
|
||||
[base-url]
|
||||
{:resource (resource-url base-url)
|
||||
:authorization_servers [base-url]
|
||||
:scopes_supported [scope]
|
||||
:bearer_methods_supported ["header"]
|
||||
:resource_name "tbd MCP server"})
|
||||
|
||||
(defn authorization-server-metadata
|
||||
"RFC 8414: where a client registers, sends the user, and trades codes for tokens."
|
||||
[base-url]
|
||||
{:issuer base-url
|
||||
:authorization_endpoint (str base-url "/oauth/authorize")
|
||||
:token_endpoint (str base-url "/oauth/token")
|
||||
:registration_endpoint (str base-url "/oauth/register")
|
||||
:scopes_supported [scope]
|
||||
:response_types_supported ["code"]
|
||||
:grant_types_supported ["authorization_code" "refresh_token"]
|
||||
:code_challenge_methods_supported ["S256"]
|
||||
:token_endpoint_auth_methods_supported ["none"]
|
||||
:authorization_response_iss_parameter_supported true})
|
||||
|
||||
(def ^:private secure-random (SecureRandom.))
|
||||
|
||||
(defn random-token
|
||||
"256 random bits, URL-safe: an authorization code, access token, refresh token or CSRF token."
|
||||
[]
|
||||
(let [bytes (byte-array 32)]
|
||||
(.nextBytes secure-random bytes)
|
||||
(.encodeToString (.withoutPadding (Base64/getUrlEncoder)) bytes)))
|
||||
|
||||
(defn- sha-256 ^bytes [^String s]
|
||||
(.digest (MessageDigest/getInstance "SHA-256") (.getBytes s StandardCharsets/UTF_8)))
|
||||
|
||||
(defn hash-token
|
||||
"What is stored in place of a code or token, so a copy of the database can't be used to act
|
||||
as anyone. The tokens are 256 random bits, so a plain fast hash is enough."
|
||||
[token]
|
||||
(.formatHex (HexFormat/of) (sha-256 token)))
|
||||
|
||||
;; --- PKCE (RFC 7636); only S256 is accepted ---
|
||||
|
||||
(defn pkce-challenge [verifier]
|
||||
(.encodeToString (.withoutPadding (Base64/getUrlEncoder)) (sha-256 verifier)))
|
||||
|
||||
(defn challenge-format?
|
||||
"A S256 challenge is a SHA-256 digest, base64url without padding: always 43 characters."
|
||||
[challenge]
|
||||
(boolean (and (string? challenge) (re-matches #"[A-Za-z0-9_-]{43}" challenge))))
|
||||
|
||||
(defn pkce-valid? [challenge verifier]
|
||||
(and (string? verifier)
|
||||
(boolean (re-matches #"[A-Za-z0-9._~-]{43,128}" verifier))
|
||||
(auth/state-matches? challenge (pkce-challenge verifier))))
|
||||
|
||||
;; --- Redirect URIs ---
|
||||
|
||||
(def ^:private forbidden-schemes
|
||||
"Schemes that would run or read something in the browser instead of handing the code to an app."
|
||||
#{"javascript" "data" "file" "vbscript" "about" "blob" "ftp"})
|
||||
|
||||
(defn- parse-uri [s]
|
||||
(when (and (string? s) (<= (count s) 2048))
|
||||
(try (URI. s) (catch URISyntaxException _ nil))))
|
||||
|
||||
(defn- loopback? [^URI uri]
|
||||
(and (= "http" (.getScheme uri))
|
||||
(contains? #{"localhost" "127.0.0.1" "[::1]"} (.getHost uri))))
|
||||
|
||||
(defn valid-redirect-uri?
|
||||
"What a client may register: https, http to the local machine (a CLI listening on a port),
|
||||
or an app's own scheme (`cursor://...`). No fragment, no credentials in the URL."
|
||||
[s]
|
||||
(if-let [uri (parse-uri s)]
|
||||
(let [scheme (some-> (.getScheme uri) str/lower-case)]
|
||||
(boolean
|
||||
(and scheme
|
||||
(nil? (.getRawFragment uri))
|
||||
(nil? (.getUserInfo uri))
|
||||
(not (contains? forbidden-schemes scheme))
|
||||
(case scheme
|
||||
"https" (some? (.getHost uri))
|
||||
"http" (loopback? uri)
|
||||
true))))
|
||||
false))
|
||||
|
||||
(defn redirect-uri-matches?
|
||||
"Exact match with a registered URI, except that a client on the local machine may pick its
|
||||
port each time (RFC 8252), so loopback URIs are compared without it."
|
||||
[registered actual]
|
||||
(boolean
|
||||
(or (= registered actual)
|
||||
(let [r (parse-uri registered), a (parse-uri actual)]
|
||||
(and r a (loopback? r) (loopback? a)
|
||||
(= (.getHost r) (.getHost a))
|
||||
(= (.getRawPath r) (.getRawPath a))
|
||||
(= (.getRawQuery r) (.getRawQuery a)))))))
|
||||
|
||||
(defn redirect-with
|
||||
"`uri` with `params` (nil values dropped) added to its query."
|
||||
[uri params]
|
||||
(str uri (if (str/includes? uri "?") "&" "?")
|
||||
(auth/form-encode (remove (comp nil? val) params))))
|
||||
|
||||
;; --- Scopes and resources ---
|
||||
|
||||
(defn parse-scope
|
||||
"The scope a request asks for: `scope` when unspecified, or nil when it asks for anything else."
|
||||
[requested]
|
||||
(if (str/blank? requested)
|
||||
scope
|
||||
(when (= [scope] (str/split (str/trim requested) #"\s+"))
|
||||
scope)))
|
||||
|
||||
(defn resource-ok?
|
||||
"The RFC 8707 `resource` a request names (a string, several, or nothing) must be this MCP server."
|
||||
[base-url resource]
|
||||
(every? #(= (resource-url base-url) (str/replace % #"/+$" ""))
|
||||
(if (string? resource) [resource] resource)))
|
||||
@@ -0,0 +1,129 @@
|
||||
(ns tbd.oauth.db
|
||||
"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]
|
||||
[next.jdbc :as jdbc]
|
||||
[next.jdbc.result-set :as rs]
|
||||
[tbd.sqlite :as sqlite]))
|
||||
|
||||
;; A user's approval of a client: the current access and refresh token (hashed), replaced
|
||||
;; together when the refresh token is used. Deleting the row revokes the approval. `id` is a
|
||||
;; UUID (see tbd.sqlite/new-id); `user_id` is the user's id in Gitea, which the app doesn't issue.
|
||||
(def ^:private create-grants
|
||||
"CREATE TABLE IF NOT EXISTS grants (
|
||||
id TEXT PRIMARY KEY,
|
||||
client_id TEXT NOT NULL,
|
||||
user_id INTEGER NOT NULL,
|
||||
login TEXT NOT NULL,
|
||||
scope TEXT NOT NULL,
|
||||
access_hash TEXT NOT NULL UNIQUE,
|
||||
access_expires_at INTEGER NOT NULL,
|
||||
refresh_hash TEXT NOT NULL UNIQUE,
|
||||
refresh_expires_at INTEGER NOT NULL,
|
||||
created_at INTEGER NOT NULL)")
|
||||
|
||||
(defn migrate!
|
||||
"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,
|
||||
name TEXT NOT NULL,
|
||||
redirect_uris TEXT NOT NULL,
|
||||
created_at INTEGER NOT NULL)"])
|
||||
;; One-time authorization codes, deleted when used.
|
||||
(jdbc/execute! ds ["CREATE TABLE IF NOT EXISTS codes (
|
||||
hash TEXT PRIMARY KEY,
|
||||
client_id TEXT NOT NULL,
|
||||
user_id INTEGER NOT NULL,
|
||||
login TEXT NOT NULL,
|
||||
redirect_uri TEXT NOT NULL,
|
||||
code_challenge TEXT NOT NULL,
|
||||
scope TEXT NOT NULL,
|
||||
expires_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 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]
|
||||
(sqlite/open path migrate!))
|
||||
|
||||
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
|
||||
|
||||
;; --- clients ---
|
||||
|
||||
(defn insert-client!
|
||||
[ds {:keys [id name redirect-uris created-at]}]
|
||||
(jdbc/execute! ds ["INSERT INTO clients (id, name, redirect_uris, created_at) VALUES (?, ?, ?, ?)"
|
||||
id name (pr-str redirect-uris) created-at]))
|
||||
|
||||
(defn find-client
|
||||
"The registered client as {:id :name :redirect-uris :created-at}, or nil."
|
||||
[ds id]
|
||||
(some-> (jdbc/execute-one! ds ["SELECT * FROM clients WHERE id = ?" id] opts)
|
||||
(update :redirect-uris edn/read-string)))
|
||||
|
||||
(defn prune!
|
||||
"Registration is open to anyone, so drop what nobody is using: expired codes, grants whose
|
||||
refresh token has expired (nothing can renew them), and clients registered before
|
||||
`unused-before` that were never approved by anyone."
|
||||
[ds now unused-before]
|
||||
(jdbc/execute! ds ["DELETE FROM codes WHERE expires_at <= ?" now])
|
||||
(jdbc/execute! ds ["DELETE FROM grants WHERE refresh_expires_at <= ?" now])
|
||||
(jdbc/execute! ds ["DELETE FROM clients WHERE created_at < ?
|
||||
AND id NOT IN (SELECT client_id FROM grants)
|
||||
AND id NOT IN (SELECT client_id FROM codes)"
|
||||
unused-before]))
|
||||
|
||||
;; --- authorization codes ---
|
||||
|
||||
(defn insert-code!
|
||||
[ds {:keys [hash client-id user-id login redirect-uri code-challenge scope expires-at]}]
|
||||
(jdbc/execute! ds ["INSERT INTO codes (hash, client_id, user_id, login, redirect_uri,
|
||||
code_challenge, scope, expires_at)
|
||||
VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
|
||||
hash client-id user-id login redirect-uri code-challenge scope expires-at]))
|
||||
|
||||
(defn take-code!
|
||||
"Removes and returns the code, or nil if there is none. Whoever gets a row is the only one who
|
||||
ever will, so a code can't be used twice, even by two requests at once."
|
||||
[ds hash]
|
||||
(jdbc/execute-one! ds ["DELETE FROM codes WHERE hash = ? RETURNING *" hash] opts))
|
||||
|
||||
;; --- grants ---
|
||||
|
||||
(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 (id, client_id, user_id, login, scope, access_hash, access_expires_at,
|
||||
refresh_hash, refresh_expires_at, created_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
|
||||
"The grant whose current access token has this hash and hasn't expired at `now`, or nil."
|
||||
[ds hash now]
|
||||
(jdbc/execute-one! ds ["SELECT * FROM grants WHERE access_hash = ? AND access_expires_at > ?" hash now] opts))
|
||||
|
||||
(defn find-grant-by-refresh
|
||||
"The grant whose current refresh token has this hash, or nil (expiry is for the caller to judge)."
|
||||
[ds hash]
|
||||
(jdbc/execute-one! ds ["SELECT * FROM grants WHERE refresh_hash = ?" hash] opts))
|
||||
|
||||
(defn rotate-grant!
|
||||
"Swaps in a new access and refresh token for the grant, but only while `old-refresh-hash` is
|
||||
still its refresh token, so a refresh token works once. Returns the grant, or nil if it lost."
|
||||
[ds id old-refresh-hash {:keys [access-hash access-expires-at refresh-hash refresh-expires-at]}]
|
||||
(jdbc/execute-one! ds ["UPDATE grants SET access_hash = ?, access_expires_at = ?,
|
||||
refresh_hash = ?, refresh_expires_at = ?
|
||||
WHERE id = ? AND refresh_hash = ? RETURNING *"
|
||||
access-hash access-expires-at refresh-hash refresh-expires-at id old-refresh-hash]
|
||||
opts))
|
||||
|
||||
(defn delete-grant! [ds id]
|
||||
(jdbc/execute! ds ["DELETE FROM grants WHERE id = ?" id]))
|
||||
@@ -0,0 +1,59 @@
|
||||
(ns tbd.oauth.middleware
|
||||
"The resource-server half of MCP OAuth: `wrap-bearer-auth` guards /mcp, accepting only the
|
||||
access tokens tbd.oauth.routes issued. It is plain Ring (like /mcp itself), not reitit
|
||||
middleware, because /mcp sits outside the router's middleware chain."
|
||||
(:require [muuntaja.core :as m]
|
||||
[plumcp.core.deps.runtime :as rt]
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.oauth.core :as oauth]
|
||||
[tbd.oauth.db :as db]))
|
||||
|
||||
(defn- bearer-token [req]
|
||||
(some->> (get-in req [:headers "authorization"])
|
||||
(re-matches #"(?i)Bearer\s+(\S+)")
|
||||
second))
|
||||
|
||||
(defn- json [status headers body]
|
||||
{:status status
|
||||
:headers (merge {"Content-Type" "application/json" "Cache-Control" "no-store"} headers)
|
||||
:body (m/encode "application/json" body)})
|
||||
|
||||
(defn- unauthorized
|
||||
"A 401 that tells the client where to start the OAuth flow (RFC 9728 / RFC 6750): the
|
||||
`resource_metadata` URL is how an MCP client discovers the authorization server. `error` is
|
||||
only given when a token was presented and rejected."
|
||||
[base-url error]
|
||||
(json 401
|
||||
{"WWW-Authenticate" (str "Bearer resource_metadata=\"" base-url "/.well-known/oauth-protected-resource/mcp\""
|
||||
", scope=\"" oauth/scope "\""
|
||||
(when error (str ", error=\"" error "\"")))}
|
||||
{:error (or error "unauthorized")
|
||||
:error_description (if error "the access token is invalid or expired" "a bearer access token is required")}))
|
||||
|
||||
(defn user-key
|
||||
"Where the caller is in the request's plumcp runtime bag, which is what MCP tools get (see
|
||||
tbd.mcp.tools): a map of :login, :id, :admin? and :client-id."
|
||||
[]
|
||||
:tbd/user)
|
||||
|
||||
(defn wrap-bearer-auth
|
||||
"401 (pointing at the OAuth metadata) unless the request carries a valid access token. The
|
||||
caller goes on as `:user` ({:login :id :admin? :client-id}), also in the plumcp runtime bag
|
||||
so tools can see it. Admin-ness is decided per request from the allowlist, not baked into the
|
||||
token, so taking someone off ADMIN_USERS takes effect at once. `ds` is a delay: the database
|
||||
isn't opened for requests that carry no token."
|
||||
[handler config ds]
|
||||
(fn [req]
|
||||
(if-not (auth/configured? config)
|
||||
(json 503 {} {:error "OAuth is not configured (set GITEA_URL, GITEA_CLIENT_ID, GITEA_CLIENT_SECRET, BASE_URL)"})
|
||||
(if-let [token (bearer-token req)]
|
||||
(if-let [grant (db/find-grant-by-access @ds (oauth/hash-token token) (System/currentTimeMillis))]
|
||||
(let [user {:login (:login grant)
|
||||
:id (:user-id grant)
|
||||
:admin? (auth/admin? config (:login grant))
|
||||
:client-id (:client-id grant)}]
|
||||
(handler (-> req
|
||||
(assoc :user user)
|
||||
(rt/upsert-runtime {(user-key) user}))))
|
||||
(unauthorized (:base-url config) "invalid_token"))
|
||||
(unauthorized (:base-url config) nil)))))
|
||||
@@ -0,0 +1,323 @@
|
||||
(ns tbd.oauth.routes
|
||||
"The OAuth endpoints MCP clients use to get a token for /mcp (RFC 9728 / 8414 discovery,
|
||||
RFC 7591 registration, authorization-code flow with PKCE). The user logs in with Gitea as
|
||||
usual (tbd.auth.routes) and approves the client on a consent page; the token the client gets
|
||||
is tbd's own, checked by tbd.oauth.middleware. What is valid is decided in tbd.oauth.core.
|
||||
|
||||
These endpoints speak the formats RFC 6749 requires (JSON, and forms in), whatever the
|
||||
request's Accept header says, so like /mcp they sit outside the API's muuntaja/coercion chain."
|
||||
(:require [clojure.string :as str]
|
||||
[muuntaja.core :as m]
|
||||
[reitit.ring.middleware.parameters :as parameters]
|
||||
[ring.util.response :as response]
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.auth.middleware :as auth-mw]
|
||||
[tbd.oauth.core :as oauth]
|
||||
[tbd.oauth.db :as db])
|
||||
(:import (java.io InputStream)))
|
||||
|
||||
(defn- now [] (System/currentTimeMillis))
|
||||
|
||||
(defn- json [status body]
|
||||
{:status status
|
||||
:headers {"Content-Type" "application/json" "Cache-Control" "no-store"}
|
||||
:body (m/encode "application/json" body)})
|
||||
|
||||
(defn- only-when-configured
|
||||
"Without the Gitea login there is nobody to approve a client, and no base URL to name in metadata."
|
||||
[config handler]
|
||||
(fn [req]
|
||||
(if (auth/configured? config)
|
||||
(handler req)
|
||||
(json 503 {:error "OAuth is not configured (set GITEA_URL, GITEA_CLIENT_ID, GITEA_CLIENT_SECRET, BASE_URL)"}))))
|
||||
|
||||
(defn- param
|
||||
"A form or query parameter's value when it was given exactly once."
|
||||
[params k]
|
||||
(let [v (get params k)]
|
||||
(when (string? v) v)))
|
||||
|
||||
;; --- discovery ---
|
||||
|
||||
(defn- metadata-handler [f config]
|
||||
(fn [_req] (json 200 (f (:base-url config)))))
|
||||
|
||||
;; --- dynamic client registration (RFC 7591) ---
|
||||
|
||||
(def ^:private max-registration-bytes 16384)
|
||||
(def ^:private max-redirect-uris 10)
|
||||
(def ^:private max-name-length 100)
|
||||
(def ^:private unused-client-ttl-ms (* 7 24 60 60 1000))
|
||||
|
||||
(defn- read-json-object
|
||||
"The request body as a map, or nil if it is missing, too big, or not a JSON object. The size
|
||||
is capped because anyone can call this."
|
||||
[^InputStream body]
|
||||
(when body
|
||||
(let [bytes (.readNBytes body (inc max-registration-bytes))]
|
||||
(when (<= (alength bytes) max-registration-bytes)
|
||||
(try
|
||||
(let [v (m/decode "application/json" bytes)]
|
||||
(when (map? v) v))
|
||||
(catch Exception _ nil))))))
|
||||
|
||||
(defn- invalid-metadata [description]
|
||||
(json 400 {:error "invalid_client_metadata" :error_description description}))
|
||||
|
||||
(defn- register-handler [ds]
|
||||
(fn [{:keys [body]}]
|
||||
(let [{:keys [redirect_uris client_name token_endpoint_auth_method grant_types response_types] :as metadata}
|
||||
(read-json-object body)
|
||||
subset-of? (fn [allowed v] (or (nil? v) (and (sequential? v) (every? allowed v))))]
|
||||
(cond
|
||||
(nil? metadata) (invalid-metadata "the body must be a JSON object of at most 16 KB")
|
||||
(not (and (vector? redirect_uris) (<= 1 (count redirect_uris) max-redirect-uris) (every? string? redirect_uris)))
|
||||
(invalid-metadata (str "redirect_uris must list 1 to " max-redirect-uris " URIs"))
|
||||
(not (every? oauth/valid-redirect-uri? redirect_uris))
|
||||
(json 400 {:error "invalid_redirect_uri"
|
||||
:error_description "redirect URIs must be https, http on localhost, or an app's own scheme, with no fragment"})
|
||||
(not (contains? #{nil "none"} token_endpoint_auth_method))
|
||||
(invalid-metadata "only public clients are supported (token_endpoint_auth_method none)")
|
||||
(not (subset-of? #{"authorization_code" "refresh_token"} grant_types))
|
||||
(invalid-metadata "grant_types can be authorization_code and refresh_token")
|
||||
(not (subset-of? #{"code"} response_types))
|
||||
(invalid-metadata "response_types can be code")
|
||||
:else
|
||||
(let [t (now)
|
||||
client {:id (str (random-uuid))
|
||||
:name (if (and (string? client_name) (not (str/blank? client_name)))
|
||||
(let [n (str/trim client_name)] (subs n 0 (min (count n) max-name-length)))
|
||||
"Unnamed application")
|
||||
:redirect-uris redirect_uris
|
||||
:created-at t}]
|
||||
(db/prune! @ds t (- t unused-client-ttl-ms))
|
||||
(db/insert-client! @ds client)
|
||||
(json 201 {:client_id (:id client)
|
||||
:client_id_issued_at (quot t 1000)
|
||||
:client_name (:name client)
|
||||
:redirect_uris redirect_uris
|
||||
:grant_types ["authorization_code" "refresh_token"]
|
||||
:response_types ["code"]
|
||||
:token_endpoint_auth_method "none"}))))))
|
||||
|
||||
;; --- authorization endpoint ---
|
||||
|
||||
(defn- esc [s]
|
||||
(-> (str s)
|
||||
(str/replace "&" "&") (str/replace "<" "<") (str/replace ">" ">")
|
||||
(str/replace "\"" """) (str/replace "'" "'")))
|
||||
|
||||
(defn- html
|
||||
"A page that can't be framed (it is a consent screen) or cached. `form-action` is left out of
|
||||
the policy on purpose: approving redirects to the client's own address, which may be any
|
||||
scheme, and browsers apply that directive to the redirect too."
|
||||
[status title & body]
|
||||
{:status status
|
||||
:headers {"Content-Type" "text/html; charset=utf-8"
|
||||
"Cache-Control" "no-store"
|
||||
"X-Frame-Options" "DENY"
|
||||
"Content-Security-Policy" "default-src 'none'; style-src 'unsafe-inline'; frame-ancestors 'none'; base-uri 'none'"}
|
||||
:body (str "<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\">"
|
||||
"<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">"
|
||||
"<title>" (esc title) "</title><style>"
|
||||
":root{color-scheme:light dark}"
|
||||
"body{font:16px/1.5 system-ui,sans-serif;margin:0;padding:16px}"
|
||||
"main{max-width:32rem;margin:8vh auto 0}"
|
||||
"code{word-break:break-all}"
|
||||
"button{font:inherit;padding:.5em 1.2em;margin-right:.5em;cursor:pointer}"
|
||||
"</style></head><body><main><h1>" (esc title) "</h1>" (apply str body) "</main></body></html>")})
|
||||
|
||||
(defn- error-page [status message]
|
||||
(html status "Can't connect this application" "<p>" (esc message) "</p>"))
|
||||
|
||||
(defn- validate-authorization
|
||||
"Checks an authorization request's parameters (query or form). One of:
|
||||
{:request {...}} good
|
||||
{:page-error \"...\"} the client or redirect URI can't be trusted, so don't redirect
|
||||
{:error :description :redirect-uri :state} anything else, to be reported to the client's redirect URI"
|
||||
[config ds params]
|
||||
(let [client (some->> (param params "client_id") (db/find-client @ds))
|
||||
redirect-uri (param params "redirect_uri")
|
||||
state (param params "state")
|
||||
challenge (param params "code_challenge")
|
||||
scope (oauth/parse-scope (param params "scope"))
|
||||
fail (fn [error description]
|
||||
{:error error :description description :redirect-uri redirect-uri :state state})]
|
||||
(cond
|
||||
(nil? client) {:page-error "This link names an application tbd doesn't know. Start the connection again from your MCP client."}
|
||||
(not (some #(oauth/redirect-uri-matches? % redirect-uri) (:redirect-uris client)))
|
||||
{:page-error "This link's return address isn't one the application registered. Start the connection again from your MCP client."}
|
||||
(not= "code" (param params "response_type")) (fail "unsupported_response_type" "response_type must be code")
|
||||
(not (oauth/challenge-format? challenge)) (fail "invalid_request" "code_challenge is required (PKCE, S256)")
|
||||
(not= "S256" (param params "code_challenge_method")) (fail "invalid_request" "code_challenge_method must be S256")
|
||||
(nil? scope) (fail "invalid_scope" (str "the only scope is " oauth/scope))
|
||||
(not (oauth/resource-ok? (:base-url config) (get params "resource"))) (fail "invalid_target" "resource must be the MCP server")
|
||||
:else {:request {:client client :redirect-uri redirect-uri :state state
|
||||
:code-challenge challenge :scope scope
|
||||
:resource (param params "resource")}})))
|
||||
|
||||
(defn- redirect-error [config {:keys [redirect-uri state error description]}]
|
||||
(response/redirect (oauth/redirect-with redirect-uri {:error error
|
||||
:error_description description
|
||||
:state state
|
||||
:iss (:base-url config)})
|
||||
:see-other))
|
||||
|
||||
(defn- consent-page [{:keys [client redirect-uri state code-challenge scope resource]} user csrf]
|
||||
(let [hidden (fn [k v] (when v (str "<input type=\"hidden\" name=\"" k "\" value=\"" (esc v) "\">")))]
|
||||
(html 200 "Connect an application"
|
||||
"<p><strong>" (esc (:name client)) "</strong> wants to use the tbd MCP server as "
|
||||
"<strong>" (esc (:login user)) "</strong>: it will be able to call every tool the server offers, "
|
||||
"with your access.</p>"
|
||||
"<p>If you approve, your browser goes back to <code>" (esc redirect-uri) "</code>. "
|
||||
"Only approve if you started this from that application.</p>"
|
||||
"<form method=\"post\" action=\"/oauth/authorize\">"
|
||||
(hidden "csrf" csrf)
|
||||
(hidden "client_id" (:id client))
|
||||
(hidden "redirect_uri" redirect-uri)
|
||||
(hidden "response_type" "code")
|
||||
(hidden "code_challenge" code-challenge)
|
||||
(hidden "code_challenge_method" "S256")
|
||||
(hidden "scope" scope)
|
||||
(hidden "state" state)
|
||||
(hidden "resource" resource)
|
||||
"<button type=\"submit\" name=\"decision\" value=\"approve\">Approve</button>"
|
||||
"<button type=\"submit\" name=\"decision\" value=\"deny\">Deny</button>"
|
||||
"</form>")))
|
||||
|
||||
(defn- authorize-get-handler [config ds]
|
||||
(fn [{:keys [query-params query-string session] :as req}]
|
||||
(let [result (validate-authorization config ds query-params)]
|
||||
(cond
|
||||
(:page-error result) (error-page 400 (:page-error result))
|
||||
(:error result) (redirect-error config result)
|
||||
;; Not logged in: do that first (Gitea), which then sends the browser back here.
|
||||
(nil? (auth-mw/current-user req))
|
||||
(response/redirect (str "/auth/login?" (auth/form-encode {:return_to (str "/oauth/authorize?" query-string)})))
|
||||
:else
|
||||
(let [csrf (oauth/random-token)]
|
||||
(-> (consent-page (:request result) (auth-mw/current-user req) csrf)
|
||||
(assoc :session (assoc session :oauth-csrf csrf))))))))
|
||||
|
||||
(defn- approve [config ds {:keys [client redirect-uri state code-challenge scope]} user]
|
||||
(let [code (oauth/random-token)]
|
||||
(db/insert-code! @ds {:hash (oauth/hash-token code)
|
||||
:client-id (:id client)
|
||||
:user-id (:id user)
|
||||
:login (:login user)
|
||||
:redirect-uri redirect-uri
|
||||
:code-challenge code-challenge
|
||||
:scope scope
|
||||
:expires-at (+ (now) oauth/code-ttl-ms)})
|
||||
(response/redirect (oauth/redirect-with redirect-uri {:code code :state state :iss (:base-url config)})
|
||||
:see-other)))
|
||||
|
||||
(defn- authorize-post-handler
|
||||
"The consent form. The CSRF token (kept in the session when the form was shown) is what makes
|
||||
it the user's own click, not another site posting for them."
|
||||
[config ds]
|
||||
(fn [{:keys [form-params session] :as req}]
|
||||
(let [user (auth-mw/current-user req)]
|
||||
(cond
|
||||
(nil? user) (error-page 401 "You are signed out. Start the connection again from your MCP client.")
|
||||
(not (auth/state-matches? (:oauth-csrf session) (param form-params "csrf")))
|
||||
(error-page 400 "This form expired. Start the connection again from your MCP client.")
|
||||
:else
|
||||
(let [result (validate-authorization config ds form-params)]
|
||||
(-> (cond
|
||||
(:page-error result) (error-page 400 (:page-error result))
|
||||
(:error result) (redirect-error config result)
|
||||
(= "approve" (param form-params "decision")) (approve config ds (:request result) user)
|
||||
:else (redirect-error config {:redirect-uri (get-in result [:request :redirect-uri])
|
||||
:state (get-in result [:request :state])
|
||||
:error "access_denied"
|
||||
:description "the user denied the request"}))
|
||||
(assoc :session (dissoc session :oauth-csrf))))))))
|
||||
|
||||
;; --- token endpoint ---
|
||||
|
||||
(defn- token-error [error description]
|
||||
(json 400 {:error error :error_description description}))
|
||||
|
||||
(defn- new-tokens
|
||||
"A fresh access and refresh token: [the grant's new columns, the token response]."
|
||||
[t scope]
|
||||
(let [access (oauth/random-token)
|
||||
refresh (oauth/random-token)]
|
||||
[{:access-hash (oauth/hash-token access)
|
||||
:access-expires-at (+ t oauth/access-ttl-ms)
|
||||
:refresh-hash (oauth/hash-token refresh)
|
||||
:refresh-expires-at (+ t oauth/refresh-ttl-ms)}
|
||||
{:access_token access
|
||||
:token_type "Bearer"
|
||||
:expires_in (quot oauth/access-ttl-ms 1000)
|
||||
:refresh_token refresh
|
||||
:scope scope}]))
|
||||
|
||||
(defn- code-grant [ds form]
|
||||
(let [t (now)
|
||||
[code verifier redirect-uri client-id] (map #(param form %) ["code" "code_verifier" "redirect_uri" "client_id"])]
|
||||
(cond
|
||||
(some str/blank? [code verifier redirect-uri client-id])
|
||||
(token-error "invalid_request" "code, code_verifier, redirect_uri and client_id are required")
|
||||
(nil? (db/find-client @ds client-id)) (token-error "invalid_client" "unknown client_id")
|
||||
:else
|
||||
;; A code is used up by the first attempt, right or wrong, so it can't be guessed at.
|
||||
(let [row (db/take-code! @ds (oauth/hash-token code))]
|
||||
(if (and row
|
||||
(= client-id (:client-id row))
|
||||
(= redirect-uri (:redirect-uri row))
|
||||
(< t (:expires-at row))
|
||||
(oauth/pkce-valid? (:code-challenge row) verifier))
|
||||
(let [[columns body] (new-tokens t (:scope row))]
|
||||
(db/insert-grant! @ds (assoc columns
|
||||
:client-id client-id :user-id (:user-id row) :login (:login row)
|
||||
:scope (:scope row) :created-at t))
|
||||
(json 200 body))
|
||||
(token-error "invalid_grant" "the code is invalid, expired, or was already used"))))))
|
||||
|
||||
(defn- refresh-grant [ds form]
|
||||
(let [t (now)
|
||||
refresh (param form "refresh_token")
|
||||
client-id (param form "client_id")]
|
||||
(if (or (str/blank? refresh) (str/blank? client-id))
|
||||
(token-error "invalid_request" "refresh_token and client_id are required")
|
||||
(let [old-hash (oauth/hash-token refresh)
|
||||
grant (db/find-grant-by-refresh @ds old-hash)
|
||||
invalid (token-error "invalid_grant" "the refresh token is invalid or expired")]
|
||||
(cond
|
||||
(or (nil? grant) (not= client-id (:client-id grant))) invalid
|
||||
(>= t (:refresh-expires-at grant)) (do (db/delete-grant! @ds (:id grant)) invalid)
|
||||
:else
|
||||
;; The old refresh token stops working with this: a token is good for one refresh.
|
||||
(let [[columns body] (new-tokens t (:scope grant))]
|
||||
(if (db/rotate-grant! @ds (:id grant) old-hash columns)
|
||||
(json 200 body)
|
||||
invalid)))))))
|
||||
|
||||
(defn- token-handler [ds]
|
||||
(fn [{:keys [form-params]}]
|
||||
(case (param form-params "grant_type")
|
||||
"authorization_code" (code-grant ds form-params)
|
||||
"refresh_token" (refresh-grant ds form-params)
|
||||
(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.sqlite/open), so the database isn't touched until needed."
|
||||
[config ds]
|
||||
(let [guarded #(only-when-configured config %)]
|
||||
["" {:no-doc true
|
||||
;; ^:replace: not the API's muuntaja/coercion chain (see the namespace docstring); just
|
||||
;; the query and form parameters.
|
||||
:middleware ^:replace [parameters/parameters-middleware]}
|
||||
["/.well-known/oauth-protected-resource"
|
||||
{:get {:handler (guarded (metadata-handler oauth/protected-resource-metadata config))}}]
|
||||
;; RFC 9728 puts the resource's path after the well-known prefix; clients try this one first.
|
||||
["/.well-known/oauth-protected-resource/mcp"
|
||||
{:get {:handler (guarded (metadata-handler oauth/protected-resource-metadata config))}}]
|
||||
["/.well-known/oauth-authorization-server"
|
||||
{:get {:handler (guarded (metadata-handler oauth/authorization-server-metadata config))}}]
|
||||
["/oauth/register" {:post {:handler (guarded (register-handler ds))}}]
|
||||
["/oauth/authorize" {:get {:handler (guarded (authorize-get-handler config ds))}
|
||||
:post {:handler (guarded (authorize-post-handler config ds))}}]
|
||||
["/oauth/token" {:post {:handler (guarded (token-handler ds))}}]]))
|
||||
@@ -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))))))))
|
||||
@@ -0,0 +1,40 @@
|
||||
(ns tbd.todo.core
|
||||
"Business logic for the todo group: validation and state changes on plain maps. No HTTP and
|
||||
no database (see tbd.todo.db); anything time-dependent takes `now` (epoch ms) as an argument.
|
||||
|
||||
Fallible fns return {:ok value} or {:error message}."
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
(def max-title-length 200)
|
||||
|
||||
(defn validate-title
|
||||
"Titles are trimmed, and must be non-blank and at most `max-title-length` characters."
|
||||
[title]
|
||||
(let [title (some-> title str/trim)]
|
||||
(cond
|
||||
(str/blank? title) {:error "title must not be blank"}
|
||||
(> (count title) max-title-length) {:error (format "title must be at most %d characters" max-title-length)}
|
||||
:else {:ok title})))
|
||||
|
||||
(defn new-todo
|
||||
"A todo for `owner-id`, not yet stored (so no :id)."
|
||||
[owner-id title now]
|
||||
(let [{:keys [ok error]} (validate-title title)]
|
||||
(if error
|
||||
{:error error}
|
||||
{:ok {:owner-id owner-id :title ok :done false :created-at now :updated-at now}})))
|
||||
|
||||
(defn apply-changes
|
||||
"`todo` with `changes` (a map with :title and/or :done) applied. Anything else in `changes`
|
||||
is ignored; a change with neither is an error."
|
||||
[todo changes now]
|
||||
(let [changes (select-keys changes [:title :done])
|
||||
{:keys [ok error]} (if (contains? changes :title)
|
||||
(validate-title (:title changes))
|
||||
{:ok (:title todo)})]
|
||||
(cond
|
||||
(empty? changes) {:error "nothing to change: give a title and/or done"}
|
||||
error {:error error}
|
||||
:else {:ok (-> todo
|
||||
(assoc :title ok :updated-at now)
|
||||
(cond-> (contains? changes :done) (assoc :done (boolean (:done changes)))))})))
|
||||
@@ -0,0 +1,73 @@
|
||||
(ns tbd.todo.db
|
||||
"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 [next.jdbc :as jdbc]
|
||||
[next.jdbc.result-set :as rs]
|
||||
[tbd.sqlite :as sqlite]))
|
||||
|
||||
(def ^:private create-todos
|
||||
;; `id` is a UUID (see tbd.sqlite/new-id); `owner_id` is the user's id in Gitea, which the app
|
||||
;; doesn't issue, so it stays the integer Gitea gave.
|
||||
"CREATE TABLE IF NOT EXISTS todos (
|
||||
id TEXT PRIMARY KEY,
|
||||
owner_id INTEGER NOT NULL,
|
||||
title TEXT NOT NULL,
|
||||
done INTEGER NOT NULL DEFAULT 0,
|
||||
created_at INTEGER NOT NULL,
|
||||
updated_at INTEGER NOT NULL)")
|
||||
|
||||
(defn migrate!
|
||||
"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 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]
|
||||
(sqlite/open path migrate!))
|
||||
|
||||
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
|
||||
|
||||
;; SQLite has no boolean type; `done` is stored as 0/1.
|
||||
(defn- row->todo [row]
|
||||
(some-> row (update :done #(= 1 %))))
|
||||
|
||||
(defn insert!
|
||||
"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 (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
|
||||
"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 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)."
|
||||
[ds owner-id id]
|
||||
(row->todo
|
||||
(jdbc/execute-one! ds ["SELECT * FROM todos WHERE owner_id = ? AND id = ?" owner-id id] opts)))
|
||||
|
||||
(defn update!
|
||||
"Writes the todo's :title, :done and :updated-at; returns the stored row, or nil if the owner has no such todo."
|
||||
[ds owner-id {:keys [id title done updated-at]}]
|
||||
(row->todo
|
||||
(jdbc/execute-one! ds ["UPDATE todos SET title = ?, done = ?, updated_at = ?
|
||||
WHERE owner_id = ? AND id = ? RETURNING *"
|
||||
title (if done 1 0) updated-at owner-id id]
|
||||
opts)))
|
||||
|
||||
(defn delete!
|
||||
"True if the owner's todo existed and is now gone."
|
||||
[ds owner-id id]
|
||||
(pos? (::jdbc/update-count
|
||||
(jdbc/execute-one! ds ["DELETE FROM todos WHERE owner_id = ? AND id = ?" owner-id id]))))
|
||||
@@ -0,0 +1,62 @@
|
||||
(ns tbd.todo.routes
|
||||
(:require [tbd.http :refer [respond]]
|
||||
[tbd.todo.core :as todo]
|
||||
[tbd.todo.schema :as schema]
|
||||
[tbd.todo.service :as service]))
|
||||
|
||||
;; Todos belong to the logged-in user (:login? true puts them on the request as :user); the
|
||||
;; rules, and the scoping to that user, are tbd.todo.service's, shared with the MCP tools. These
|
||||
;; handlers only turn a service result into a response.
|
||||
(def ^:private error-status {:invalid 400 :not-found 404})
|
||||
|
||||
(defn- reply
|
||||
"The response for a service `result`: `status` and `(shape value)` when it is ok, else the
|
||||
error's status and message."
|
||||
([status result] (reply status identity result))
|
||||
([status shape {:keys [ok error kind]}]
|
||||
(if error
|
||||
(respond (error-status kind) {:error error})
|
||||
(respond status (shape ok)))))
|
||||
|
||||
(defn- list-handler [ds]
|
||||
(fn [{:keys [user]}]
|
||||
(reply 200 (fn [todos] {:todos todos}) (service/list-todos ds user))))
|
||||
|
||||
(defn- create-handler [ds]
|
||||
(fn [{{{:keys [title]} :body} :parameters :keys [user]}]
|
||||
(reply 201 (service/create! ds user title))))
|
||||
|
||||
(defn- get-handler [ds]
|
||||
(fn [{{{:keys [id]} :path} :parameters :keys [user]}]
|
||||
(reply 200 (service/find-todo ds user id))))
|
||||
|
||||
(defn- patch-handler [ds]
|
||||
(fn [{{{:keys [id]} :path changes :body} :parameters :keys [user]}]
|
||||
(reply 200 (service/update! ds user id changes))))
|
||||
|
||||
(defn- delete-handler [ds]
|
||||
(fn [{{{:keys [id]} :path} :parameters :keys [user]}]
|
||||
(reply 200 (fn [_] {:deleted true}) (service/delete! ds user id))))
|
||||
|
||||
(defn routes
|
||||
"`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"
|
||||
{:tags ["todo"] :login? true}
|
||||
[""
|
||||
{:get {:summary "List your todos (login required)"
|
||||
:handler (list-handler ds)}
|
||||
:post {:summary (format "Create a todo; the title is trimmed, non-blank, at most %d characters" todo/max-title-length)
|
||||
:parameters {:body schema/NewTodo}
|
||||
:handler (create-handler ds)}}]
|
||||
["/:id"
|
||||
{:get {:summary "One of your todos (404 if it isn't yours)"
|
||||
:parameters id-param
|
||||
:handler (get-handler ds)}
|
||||
:patch {:summary "Change the title and/or done flag of one of your todos"
|
||||
:parameters (assoc id-param :body schema/Changes)
|
||||
:handler (patch-handler ds)}
|
||||
:delete {:summary "Delete one of your todos"
|
||||
:parameters id-param
|
||||
:handler (delete-handler ds)}}]]))
|
||||
@@ -0,0 +1,33 @@
|
||||
(ns tbd.todo.schema
|
||||
"The shapes of the todo group's input, as Malli schemas. This is the one definition of them:
|
||||
the HTTP routes coerce and validate requests with it (tbd.todo.routes), and the MCP tools
|
||||
derive their input schema and validate their arguments from it (tbd.mcp.tools). They describe
|
||||
shape only (types, which keys may be missing); the rules on values (trimming, blank or too long
|
||||
titles, an empty change) stay in tbd.todo.core, applied by tbd.todo.service, which both callers
|
||||
go through."
|
||||
(:require [malli.util :as mu]
|
||||
[tbd.todo.core :as todo]))
|
||||
|
||||
(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"
|
||||
todo/max-title-length)}])
|
||||
|
||||
(def Done [:boolean {:description "Whether it is done"}])
|
||||
|
||||
(def IdParam [:map [:id Id]])
|
||||
|
||||
(def NewTodo [:map [:title Title]])
|
||||
|
||||
(def Changes
|
||||
"What may be changed on a todo; at least one of them has to be given (a rule, see tbd.todo.core)."
|
||||
[:map
|
||||
[:title {:optional true} Title]
|
||||
[:done {:optional true} Done]])
|
||||
|
||||
(def UpdateTodo (mu/merge IdParam Changes))
|
||||
@@ -0,0 +1,65 @@
|
||||
(ns tbd.todo.service
|
||||
"What a caller can do with todos: the one place that ties the rules (tbd.todo.core) to storage
|
||||
(tbd.todo.db). Both front ends, the HTTP routes (tbd.todo.routes) and the MCP tools
|
||||
(tbd.mcp.tools), call these and nothing lower, so ownership, not-found and validation behave the
|
||||
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 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.
|
||||
|
||||
Every fn returns {:ok value} or {:error message :kind kind}, where kind is :invalid (the
|
||||
input is no good) or :not-found."
|
||||
(:require [tbd.todo.core :as todo]
|
||||
[tbd.todo.db :as db]))
|
||||
|
||||
(defn- now [] (System/currentTimeMillis))
|
||||
|
||||
(defn- owner-id [user] (:id user))
|
||||
|
||||
(def ^:private not-found {:error "todo not found" :kind :not-found})
|
||||
|
||||
(defn- invalid [{:keys [error]}] {:error error :kind :invalid})
|
||||
|
||||
(defn list-todos
|
||||
"The user's todos, oldest first."
|
||||
[ds user]
|
||||
{:ok (db/list-todos @ds (owner-id user))})
|
||||
|
||||
(defn find-todo
|
||||
"The user's todo with this id."
|
||||
[ds user id]
|
||||
(if-let [found (db/find-todo @ds (owner-id user) id)]
|
||||
{:ok found}
|
||||
not-found))
|
||||
|
||||
(defn create!
|
||||
"Stores a new todo for the user and returns it."
|
||||
[ds user title]
|
||||
(let [{:keys [ok] :as built} (todo/new-todo (owner-id user) title (now))]
|
||||
(if ok
|
||||
{:ok (db/insert! @ds ok)}
|
||||
(invalid built))))
|
||||
|
||||
(defn update!
|
||||
"Applies `changes` (:title and/or :done) to the user's todo and returns it."
|
||||
[ds user id changes]
|
||||
(let [owner (owner-id user)]
|
||||
(if-let [found (db/find-todo @ds owner id)]
|
||||
(let [{:keys [ok] :as changed} (todo/apply-changes found changes (now))]
|
||||
(if ok
|
||||
;; nil only if it was deleted since the lookup.
|
||||
(if-let [stored (db/update! @ds owner ok)]
|
||||
{:ok stored}
|
||||
not-found)
|
||||
(invalid changed)))
|
||||
not-found)))
|
||||
|
||||
(defn delete!
|
||||
"Deletes the user's todo; {:ok true} once it is gone."
|
||||
[ds user id]
|
||||
(if (db/delete! @ds (owner-id user) id)
|
||||
{:ok true}
|
||||
not-found))
|
||||
@@ -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])))))
|
||||
@@ -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))))))
|
||||
@@ -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")))
|
||||
@@ -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"))
|
||||
@@ -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)))
|
||||
@@ -0,0 +1,118 @@
|
||||
(ns tbd.auth.core-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[tbd.auth.core :as auth]))
|
||||
|
||||
(def full-env
|
||||
{"GITEA_URL" "https://git.example.com/"
|
||||
"GITEA_CLIENT_ID" "cid"
|
||||
"GITEA_CLIENT_SECRET" "sec"
|
||||
"BASE_URL" "https://tbd.example.com/"
|
||||
"ADMIN_USERS" " Alice, bob ,,"
|
||||
"SESSION_SECRET" "s3cret"})
|
||||
|
||||
(deftest env-config-test
|
||||
(testing "a complete environment"
|
||||
(let [config (auth/env-config full-env)]
|
||||
(is (auth/configured? config))
|
||||
(is (= "https://git.example.com" (:gitea-url config)) "trailing slash is dropped")
|
||||
(is (= "https://tbd.example.com/auth/callback" (:redirect-uri config)))
|
||||
(is (= #{"alice" "bob"} (:admin-users config)) "trimmed, lower-cased, blanks dropped")
|
||||
(is (true? (:secure-cookies? config)) "https base URL => Secure cookies")
|
||||
(is (= "s3cret" (:session-secret config)))))
|
||||
(testing "plain http base URL does not mark cookies Secure"
|
||||
(is (false? (:secure-cookies? (auth/env-config (assoc full-env "BASE_URL" "http://localhost:3000"))))))
|
||||
(testing "an empty environment is unconfigured and has no admins"
|
||||
(let [config (auth/env-config {})]
|
||||
(is (not (auth/configured? config)))
|
||||
(is (= #{} (:admin-users config)))
|
||||
(is (nil? (:session-secret config)))))
|
||||
(testing "blank values count as unset"
|
||||
(is (not (auth/configured? (auth/env-config (assoc full-env "GITEA_CLIENT_SECRET" " "))))))
|
||||
(testing "each of the four settings is required"
|
||||
(doseq [k ["GITEA_URL" "GITEA_CLIENT_ID" "GITEA_CLIENT_SECRET" "BASE_URL"]]
|
||||
(is (not (auth/configured? (auth/env-config (dissoc full-env k)))) k))))
|
||||
|
||||
(deftest admin-test
|
||||
(let [config (auth/env-config full-env)]
|
||||
(is (auth/admin? config "alice"))
|
||||
(is (auth/admin? config "ALICE") "Gitea usernames are case-insensitive")
|
||||
(is (not (auth/admin? config "mallory")))
|
||||
(is (not (auth/admin? (auth/env-config {}) "alice")) "an empty allowlist admits nobody")))
|
||||
|
||||
(deftest session-key-test
|
||||
(is (= 16 (count (auth/session-key "s3cret"))))
|
||||
(is (= (seq (auth/session-key "s3cret")) (seq (auth/session-key "s3cret"))))
|
||||
(is (not= (seq (auth/session-key "a")) (seq (auth/session-key "b"))))
|
||||
(testing "without a secret each call yields a fresh random key"
|
||||
(is (= 16 (count (auth/session-key nil))))
|
||||
(is (not= (seq (auth/session-key nil)) (seq (auth/session-key nil))))))
|
||||
|
||||
(deftest state-test
|
||||
(let [a (auth/new-state)]
|
||||
(is (re-matches #"[A-Za-z0-9_-]{43}" a))
|
||||
(is (not= a (auth/new-state))))
|
||||
(is (auth/state-matches? "abc" "abc"))
|
||||
(is (not (auth/state-matches? "abc" "abd")))
|
||||
(is (not (auth/state-matches? "abc" "abcd")))
|
||||
(testing "a missing state never matches, even against another missing one"
|
||||
(is (not (auth/state-matches? nil nil)))
|
||||
(is (not (auth/state-matches? "abc" nil)))
|
||||
(is (not (auth/state-matches? nil "abc")))))
|
||||
|
||||
(deftest safe-return-to-test
|
||||
(doseq [ok ["/" "/oauth/authorize?client_id=a&state=b%2Fc" "/a/b#frag"]]
|
||||
(is (= ok (auth/safe-return-to ok)) ok))
|
||||
(doseq [bad [nil 42 "" "oauth/authorize" "//evil.example.com" "/\\evil.example.com" "/\\/evil.example.com"
|
||||
"https://evil.example.com" "javascript:alert(1)" "/a b" "/a\nb" (str "/" (apply str (repeat 2000 "a")))]]
|
||||
(is (nil? (auth/safe-return-to bad)) (pr-str bad))))
|
||||
|
||||
(deftest authorize-url-test
|
||||
(let [url (auth/authorize-url (auth/env-config full-env) "st ate")]
|
||||
(is (str/starts-with? url "https://git.example.com/login/oauth/authorize?"))
|
||||
(is (str/includes? url "client_id=cid"))
|
||||
(is (str/includes? url "response_type=code"))
|
||||
(is (str/includes? url "redirect_uri=https%3A%2F%2Ftbd.example.com%2Fauth%2Fcallback"))
|
||||
(is (str/includes? url "state=st+ate") "values are form-encoded")))
|
||||
|
||||
(defn- recording-http
|
||||
"An :http stub that records requests and answers with `responses` in order."
|
||||
[calls & responses]
|
||||
(let [responses (atom responses)]
|
||||
(fn [req]
|
||||
(swap! calls conj req)
|
||||
(let [[r & more] @responses]
|
||||
(reset! responses more)
|
||||
(if (instance? Throwable r) (throw r) r)))))
|
||||
|
||||
(deftest exchange-code-test
|
||||
(let [calls (atom [])
|
||||
config (assoc (auth/env-config full-env)
|
||||
:http (recording-http calls
|
||||
{:status 200 :body "{\"access_token\":\"tok\",\"token_type\":\"bearer\"}"}
|
||||
{:status 400 :body "{\"error\":\"invalid_grant\"}"}))]
|
||||
(is (= "tok" (auth/exchange-code config "the-code")))
|
||||
(let [{:keys [method url headers body]} (first @calls)]
|
||||
(is (= :post method))
|
||||
(is (= "https://git.example.com/login/oauth/access_token" url))
|
||||
(is (= "application/json" (get headers "Accept")))
|
||||
(is (= "application/x-www-form-urlencoded" (get headers "Content-Type")))
|
||||
(doseq [part ["grant_type=authorization_code" "client_id=cid" "client_secret=sec" "code=the-code"
|
||||
"redirect_uri=https%3A%2F%2Ftbd.example.com%2Fauth%2Fcallback"]]
|
||||
(is (str/includes? body part) part)))
|
||||
(is (nil? (auth/exchange-code config "used-code")) "a refused code yields nil")))
|
||||
|
||||
(deftest fetch-user-test
|
||||
(let [calls (atom [])
|
||||
config (assoc (auth/env-config full-env)
|
||||
:http (recording-http calls
|
||||
{:status 200 :body "{\"login\":\"alice\",\"id\":7,\"email\":\"a@x\"}"}
|
||||
{:status 401 :body "{}"}
|
||||
{:status 200 :body "{\"id\":7}"}))]
|
||||
(is (= {:login "alice" :id 7} (auth/fetch-user config "tok")))
|
||||
(let [{:keys [method url headers]} (first @calls)]
|
||||
(is (= :get method))
|
||||
(is (= "https://git.example.com/api/v1/user" url))
|
||||
(is (= "Bearer tok" (get headers "Authorization"))))
|
||||
(is (nil? (auth/fetch-user config "bad")) "a refused token yields nil")
|
||||
(is (nil? (auth/fetch-user config "odd")) "a response without a login yields nil")))
|
||||
@@ -0,0 +1,175 @@
|
||||
(ns tbd.auth.routes-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[tbd.auth.middleware :as mw]
|
||||
[tbd.core :as core]
|
||||
[tbd.test-util :as test-util]))
|
||||
|
||||
(defn gitea-stub
|
||||
"Stands in for Gitea: any code is exchanged for a token that resolves to `login` (with Gitea id 7, or `id`)."
|
||||
([login] (gitea-stub login 7))
|
||||
([login id]
|
||||
(fn [{:keys [url]}]
|
||||
(cond
|
||||
(str/ends-with? url "/login/oauth/access_token") {:status 200 :body "{\"access_token\":\"tok\"}"}
|
||||
(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. `: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"
|
||||
:client-secret "sec"
|
||||
:redirect-uri "http://tbd.test/auth/callback"
|
||||
:admin-users #{"alice"}
|
||||
:session-secret "test-secret"
|
||||
:secure-cookies? false
|
||||
:http http}
|
||||
(dissoc overrides :db :chat))
|
||||
:nrepl {:port 0 :bind "127.0.0.1"}}))
|
||||
|
||||
(defn request [app method uri & {:keys [cookie query]}]
|
||||
(let [resp (app (cond-> {:request-method method :uri uri :query-string query :headers {}}
|
||||
cookie (assoc-in [:headers "cookie"] cookie)))]
|
||||
(test-util/decode-body resp)))
|
||||
|
||||
(defn set-cookie
|
||||
"The `name=value` pair from a response's Set-Cookie header."
|
||||
[resp]
|
||||
(let [h (get-in resp [:headers "Set-Cookie"])]
|
||||
(first (str/split (first (if (string? h) [h] h)) #";"))))
|
||||
|
||||
(defn location-state [resp]
|
||||
(second (re-find #"[?&]state=([^&]+)" (get-in resp [:headers "Location"]))))
|
||||
|
||||
(defn login!
|
||||
"Runs the whole login dance and returns the session cookie."
|
||||
[app]
|
||||
(let [start (request app :get "/auth/login")
|
||||
done (request app :get "/auth/callback"
|
||||
:cookie (set-cookie start)
|
||||
:query (str "code=abc&state=" (location-state start)))]
|
||||
(set-cookie done)))
|
||||
|
||||
(deftest login-redirect-test
|
||||
(let [resp (request (make-app (gitea-stub "alice")) :get "/auth/login")
|
||||
location (get-in resp [:headers "Location"])]
|
||||
(is (= 302 (:status resp)))
|
||||
(is (str/starts-with? location "https://gitea.test/login/oauth/authorize?"))
|
||||
(is (str/includes? location "client_id=cid"))
|
||||
(is (some? (location-state resp)))
|
||||
(let [cookie (get-in resp [:headers "Set-Cookie"])
|
||||
cookie (first (if (string? cookie) [cookie] cookie))]
|
||||
(is (str/starts-with? cookie "tbd-session="))
|
||||
(is (re-find #"(?i)HttpOnly" cookie))
|
||||
(is (re-find #"(?i)SameSite=Lax" cookie))
|
||||
(is (not (re-find #"(?i);\s*Secure" cookie)) "http base URL, so no Secure flag"))))
|
||||
|
||||
(deftest return-to-test
|
||||
(let [login-then-callback (fn [return-to]
|
||||
(let [app (make-app (gitea-stub "alice"))
|
||||
start (request app :get "/auth/login" :query (when return-to (str "return_to=" return-to)))]
|
||||
(request app :get "/auth/callback" :cookie (set-cookie start)
|
||||
:query (str "code=abc&state=" (location-state start)))))]
|
||||
(testing "after logging in the browser goes back to where it came from"
|
||||
(is (= "/oauth/authorize?a=b" (get-in (login-then-callback "%2Foauth%2Fauthorize%3Fa%3Db") [:headers "Location"]))))
|
||||
(testing "and to / without a return_to"
|
||||
(is (= "/" (get-in (login-then-callback nil) [:headers "Location"]))))
|
||||
(testing "but never to another site"
|
||||
(doseq [bad ["https%3A%2F%2Fevil.example.com" "%2F%2Fevil.example.com" "%2F%5Cevil.example.com" "javascript%3Aalert(1)"]]
|
||||
(is (= "/" (get-in (login-then-callback bad) [:headers "Location"])) bad)))))
|
||||
|
||||
(deftest secure-cookie-test
|
||||
(let [resp (request (make-app (gitea-stub "alice") :secure-cookies? true) :get "/auth/login")
|
||||
cookie (first (let [h (get-in resp [:headers "Set-Cookie"])] (if (string? h) [h] h)))]
|
||||
(is (re-find #"(?i);\s*Secure" cookie))))
|
||||
|
||||
(deftest unconfigured-test
|
||||
(let [app (make-app (gitea-stub "alice") :gitea-url nil)]
|
||||
(is (= 503 (:status (request app :get "/auth/login"))))
|
||||
(is (= 503 (:status (request app :get "/auth/callback" :query "code=x&state=y"))))))
|
||||
|
||||
(deftest callback-test
|
||||
(let [app (make-app (gitea-stub "Alice"))
|
||||
start (request app :get "/auth/login")
|
||||
cookie (set-cookie start)
|
||||
state (location-state start)]
|
||||
(testing "a successful login redirects home and sets a session"
|
||||
(let [resp (request app :get "/auth/callback" :cookie cookie :query (str "code=abc&state=" state))]
|
||||
(is (= 302 (:status resp)))
|
||||
(is (= "/" (get-in resp [:headers "Location"])))
|
||||
(is (some? (set-cookie resp)))))
|
||||
(testing "no session cookie (the callback wasn't preceded by a login here)"
|
||||
(is (= 400 (:status (request app :get "/auth/callback" :query (str "code=abc&state=" state))))))
|
||||
(testing "wrong or missing state"
|
||||
(is (= 400 (:status (request app :get "/auth/callback" :cookie cookie :query "code=abc&state=nope"))))
|
||||
(is (= 400 (:status (request app :get "/auth/callback" :cookie cookie :query "code=abc")))))
|
||||
(testing "the user denied access at Gitea"
|
||||
(is (= 403 (:status (request app :get "/auth/callback" :cookie cookie
|
||||
:query (str "error=access_denied&state=" state))))))
|
||||
(testing "missing code"
|
||||
(is (= 400 (:status (request app :get "/auth/callback" :cookie cookie :query (str "state=" state))))))))
|
||||
|
||||
(deftest callback-gitea-failure-test
|
||||
(let [login-with (fn [http]
|
||||
(let [app (make-app http)
|
||||
start (request app :get "/auth/login")
|
||||
resp (atom nil)]
|
||||
;; the 502 path logs; keep it out of the test output
|
||||
(with-out-str
|
||||
(reset! resp (request app :get "/auth/callback" :cookie (set-cookie start)
|
||||
:query (str "code=abc&state=" (location-state start)))))
|
||||
@resp))]
|
||||
(testing "Gitea rejects the code"
|
||||
(let [resp (login-with (fn [_] {:status 400 :body "{\"error\":\"invalid_grant\"}"}))]
|
||||
(is (= 401 (:status resp)))
|
||||
(is (nil? (get-in resp [:headers "Set-Cookie"])) "no session is created")))
|
||||
(testing "Gitea rejects the token"
|
||||
(is (= 401 (:status (login-with (fn [{:keys [url]}]
|
||||
(if (str/ends-with? url "/access_token")
|
||||
{:status 200 :body "{\"access_token\":\"tok\"}"}
|
||||
{:status 401 :body "{}"})))))))
|
||||
(testing "Gitea is unreachable or answers garbage"
|
||||
(is (= 502 (:status (login-with (fn [_] (throw (java.net.ConnectException. "refused")))))))
|
||||
(is (= 502 (:status (login-with (fn [_] {:status 200 :body "<html>not json</html>"}))))))))
|
||||
|
||||
(deftest me-and-logout-test
|
||||
(let [app (make-app (gitea-stub "Alice"))
|
||||
cookie (login! app)]
|
||||
(testing "anonymous"
|
||||
(is (= 401 (:status (request app :get "/auth/me")))))
|
||||
(testing "logged in"
|
||||
(let [resp (request app :get "/auth/me" :cookie cookie)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= {:login "Alice" :id 7 :admin? true} (:body resp)))))
|
||||
(testing "logged in as a non-admin"
|
||||
(let [app (make-app (gitea-stub "bob"))]
|
||||
(is (= {:login "bob" :id 7 :admin? false}
|
||||
(:body (request app :get "/auth/me" :cookie (login! app)))))))
|
||||
(testing "logout replaces the session with an empty one"
|
||||
(let [resp (request app :post "/auth/logout" :cookie cookie)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= 401 (:status (request app :get "/auth/me" :cookie (set-cookie resp)))))))))
|
||||
|
||||
(deftest forged-session-test
|
||||
(let [app (make-app (gitea-stub "alice"))
|
||||
cookie (login! app)]
|
||||
(testing "a cookie tampered with is ignored"
|
||||
(let [tampered (str (subs cookie 0 (- (count cookie) 4)) "AAAA")]
|
||||
(is (= 401 (:status (request app :get "/auth/me" :cookie tampered))))))
|
||||
(testing "a cookie minted under another SESSION_SECRET is ignored"
|
||||
(let [other (make-app (gitea-stub "alice") :session-secret "other-secret")]
|
||||
(is (= 401 (:status (request other :get "/auth/me" :cookie cookie))))))
|
||||
(testing "garbage"
|
||||
(is (= 401 (:status (request app :get "/auth/me" :cookie "tbd-session=not-a-real-cookie")))))))
|
||||
|
||||
(deftest current-user-expiry-test
|
||||
(let [req {:session {:user {:login "alice" :expires-at 1000}}}]
|
||||
(is (= {:login "alice" :expires-at 1000} (mw/current-user req 999)))
|
||||
(is (nil? (mw/current-user req 1000)) "expired exactly at expires-at")
|
||||
(is (nil? (mw/current-user req 5000)))
|
||||
(is (nil? (mw/current-user {:session {:user {:login "alice"}}} 0)) "a user with no expiry is not trusted")
|
||||
(is (nil? (mw/current-user {} 0)))))
|
||||
@@ -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")))
|
||||
@@ -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"))))
|
||||
@@ -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]))))))
|
||||
+21
-3
@@ -12,13 +12,31 @@
|
||||
(handler {:request-method method :uri uri :headers {}}))
|
||||
|
||||
(deftest root-test
|
||||
(let [resp (request :get "/")]
|
||||
(let [resp (request :get "/")
|
||||
body (slurp (:body resp))]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "text/plain; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (re-find #"/api-docs" (:body resp))))
|
||||
(is (= "text/html; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(testing "serves the HTML shell that mounts the re-frame UI"
|
||||
(is (re-find #"<div id=\"app\"" body))
|
||||
(is (re-find #"<script src=\"/js/main\.js\"" body))))
|
||||
(testing "HEAD is served like GET, without a body"
|
||||
(is (= 200 (:status (request :head "/"))))))
|
||||
|
||||
(deftest origin-trial-header-test
|
||||
(let [get-root (fn [config]
|
||||
((core/make-app config) {:request-method :get :uri "/" :headers {}}))]
|
||||
(testing "the WebMCP origin-trial token is sent as an Origin-Trial header on the page"
|
||||
(is (= "tok-123" (get-in (get-root (assoc core/config :webmcp {:origin-trial-token "tok-123"}))
|
||||
[:headers "Origin-Trial"]))))
|
||||
(testing "no token, no header"
|
||||
(is (nil? (get-in (get-root (assoc core/config :webmcp {:origin-trial-token nil}))
|
||||
[:headers "Origin-Trial"]))))))
|
||||
|
||||
(deftest js-assets-test
|
||||
;; main.js only exists once script/ui-build has run, so only the miss is asserted here;
|
||||
;; the integration suite (which runs against the built image) checks the hit.
|
||||
(is (= 404 (:status (request :get "/js/nope.js")))))
|
||||
|
||||
(deftest swagger-spec-test
|
||||
(let [resp (request :get "/swagger.json")]
|
||||
(is (= 200 (:status resp)))
|
||||
|
||||
@@ -0,0 +1,99 @@
|
||||
(ns tbd.http-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[muuntaja.core :as m]
|
||||
[tbd.auth.routes-test :as t]
|
||||
[tbd.core :as core]
|
||||
[tbd.http :as http]
|
||||
[tbd.test-util :as test-util]
|
||||
[tbd.sqlite-test :as sqlite-test])
|
||||
(:import (java.io ByteArrayInputStream)))
|
||||
|
||||
(defn call
|
||||
"`headers` is a map; `body` a string or nil. The response body is decoded by its Content-Type."
|
||||
[app method uri headers & [body]]
|
||||
(test-util/decode-body
|
||||
(app (cond-> {:request-method method :uri uri :headers headers}
|
||||
body (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))))))
|
||||
|
||||
(defn content-type [resp] (get-in resp [:headers "Content-Type"]))
|
||||
|
||||
(defn get-add-swagger []
|
||||
(core/app {:request-method :get :uri "/swagger.json" :headers {}}))
|
||||
|
||||
(deftest response-format-test
|
||||
(let [get-add (fn [accept]
|
||||
(test-util/decode-body
|
||||
(core/app (cond-> {:request-method :get :uri "/api/add" :query-string "x=2&y=3" :headers {}}
|
||||
accept (assoc-in [:headers "accept"] accept)))))]
|
||||
(testing "EDN is the default: no Accept, or one nothing here satisfies"
|
||||
(doseq [accept [nil "*/*" "application/xml"]]
|
||||
(let [resp (get-add accept)]
|
||||
(is (= "application/edn; charset=utf-8" (content-type resp)) (str "accept: " accept))
|
||||
(is (= {:result 5} (:body resp))))))
|
||||
(testing "JSON when asked for"
|
||||
(let [resp (core/app {:request-method :get :uri "/api/add" :query-string "x=2&y=3"
|
||||
:headers {"accept" "application/json"}})]
|
||||
(is (= "application/json; charset=utf-8" (content-type resp)))
|
||||
(is (= "{\"result\":5}" (slurp (:body resp))))))
|
||||
(testing "Transit when asked for"
|
||||
(let [resp (get-add "application/transit+json")]
|
||||
(is (= "application/transit+json; charset=utf-8" (content-type resp)))
|
||||
(is (= {:result 5} (:body resp)))))
|
||||
(testing "the first Accept type we can produce wins"
|
||||
(is (= "application/json; charset=utf-8" (content-type (get-add "application/xml, application/json")))))
|
||||
(testing "text/plain responses are left alone"
|
||||
(let [resp (core/app {:request-method :get :uri "/api/ping" :headers {"accept" "application/json"}})]
|
||||
(is (= "text/plain; charset=utf-8" (content-type resp)))
|
||||
(is (= "pong" (:body resp)))))
|
||||
(testing "swagger.json stays JSON, even with no Accept header"
|
||||
(is (= "application/json; charset=utf-8" (content-type (get-add-swagger)))))))
|
||||
|
||||
(deftest error-format-test
|
||||
(testing "errors follow the same negotiation"
|
||||
(let [req (fn [accept] (core/app (cond-> {:request-method :get :uri "/api/add" :query-string "x=abc&y=3" :headers {}}
|
||||
accept (assoc-in [:headers "accept"] accept))))]
|
||||
(is (= "application/edn; charset=utf-8" (content-type (req nil))))
|
||||
(is (= "application/json; charset=utf-8" (content-type (req "application/json"))))
|
||||
(is (= 400 (:status (req "application/json"))))
|
||||
(is (contains? (:body (test-util/decode-body (req "application/json"))) :error)))
|
||||
(testing "including the auth middleware's 401"
|
||||
(let [app (t/make-app (t/gitea-stub "alice"))
|
||||
resp (call app :get "/api/todos" {"accept" "application/json"})]
|
||||
(is (= 401 (:status resp)))
|
||||
(is (= "application/json; charset=utf-8" (content-type resp)))
|
||||
(is (= {:error "login required"} (:body resp)))
|
||||
(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) :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"
|
||||
(let [resp (post {"content-type" "application/json"} "{\"title\":\"a\"}")]
|
||||
(is (= 201 (:status resp)))
|
||||
(is (= "application/edn; charset=utf-8" (content-type resp)))
|
||||
(is (= "a" (:title (:body resp))))))
|
||||
(testing "EDN in, JSON out when asked for"
|
||||
(let [resp (post {"content-type" "application/edn" "accept" "application/json"} "{:title \"b\"}")]
|
||||
(is (= 201 (:status resp)))
|
||||
(is (= "application/json; charset=utf-8" (content-type resp)))
|
||||
(is (= "b" (:title (:body resp))))))
|
||||
(testing "with no Content-Type the body is EDN"
|
||||
(let [resp (post {} "{:title \"c\"}")]
|
||||
(is (= 201 (:status resp)))
|
||||
(is (= "c" (:title (:body resp))))))
|
||||
(testing "Transit in"
|
||||
(let [body (String. (.readAllBytes (m/encode http/muuntaja "application/transit+json" {:title "d"})) "UTF-8")
|
||||
resp (post {"content-type" "application/transit+json"} body)]
|
||||
(is (= 201 (:status resp)))
|
||||
(is (= "d" (:title (:body resp))))))
|
||||
(testing "a body that isn't valid for its type is a 400 in the negotiated format"
|
||||
(let [resp (post {"content-type" "application/json" "accept" "application/json"} "{:title \"e\"}")]
|
||||
(is (= 400 (:status resp)))
|
||||
(is (= "application/json; charset=utf-8" (content-type resp)))
|
||||
(is (= {:error "malformed request body"} (:body resp))))
|
||||
(is (= 400 (:status (post {} "{\"title\":\"f\"}")))
|
||||
"JSON isn't assumed when nothing says so"))
|
||||
(testing "listing shows only what was created"
|
||||
(is (= ["a" "b" "c" "d"]
|
||||
(map :title (:todos (:body (call app :get "/api/todos" {"cookie" cookie "accept" "application/json"})))))))))
|
||||
@@ -1,18 +1,13 @@
|
||||
(ns tbd.math.routes-test
|
||||
(:require [clojure.edn :as edn]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[reitit.ring :as ring]
|
||||
[ring.middleware.params :refer [wrap-params]]
|
||||
[tbd.math.routes :as math]))
|
||||
|
||||
;; wrap-params populates :query-params, as wrap-defaults does in tbd.core.
|
||||
(def handler
|
||||
(wrap-params (ring/ring-handler (ring/router (math/routes)))))
|
||||
[muuntaja.core :as m]
|
||||
[tbd.core :as core]
|
||||
[tbd.test-util :as test-util]))
|
||||
|
||||
;; Coercion/validation is configured on the router in tbd.core, so go through the real app.
|
||||
(defn add [query]
|
||||
(let [resp (handler {:request-method :get :uri "/api/add" :query-string query})]
|
||||
(-> resp
|
||||
(update :body edn/read-string))))
|
||||
(test-util/decode-body (core/app {:request-method :get :uri "/api/add" :query-string query})))
|
||||
|
||||
(deftest add-route-test
|
||||
(testing "integers"
|
||||
@@ -27,4 +22,30 @@
|
||||
(doseq [query [nil "x=2" "y=3" "x=abc&y=3" "x=2&y=abc"]]
|
||||
(let [resp (add query)]
|
||||
(is (= 400 (:status resp)) (str "query: " query))
|
||||
(is (= "application/edn; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (contains? (:body resp) :error))))))
|
||||
|
||||
(deftest add-route-browser-test
|
||||
(testing "browser navigations get an inline-renderable type so Chrome doesn't download the EDN"
|
||||
(let [resp (core/app {:request-method :get :uri "/api/add" :query-string "x=2&y=3"
|
||||
:headers {"accept" "text/html,application/xhtml+xml,*/*;q=0.8"}})]
|
||||
(is (= "text/plain; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (= {:result 5} (edn/read-string (slurp (:body resp)))))))
|
||||
(testing "programmatic clients still get application/edn"
|
||||
(let [resp (core/app {:request-method :get :uri "/api/add" :query-string "x=2&y=3"
|
||||
:headers {"accept" "*/*"}})]
|
||||
(is (= "application/edn; charset=utf-8" (get-in resp [:headers "Content-Type"]))))))
|
||||
|
||||
(deftest add-route-swagger-test
|
||||
(let [spec (-> (core/app {:request-method :get :uri "/swagger.json"
|
||||
:headers {"accept" "application/json"}})
|
||||
:body
|
||||
(->> (m/decode "application/json")))
|
||||
params (->> (:paths spec)
|
||||
(some (fn [[path v]] (when (= "/api/add" (str (namespace path) "/" (name path))) v)))
|
||||
:get
|
||||
:parameters)]
|
||||
(testing "x and y are documented as required numeric query params"
|
||||
(is (= [{:name "x" :in "query" :type "number" :required true}
|
||||
{:name "y" :in "query" :type "number" :required true}]
|
||||
(map #(select-keys % [:name :in :type :required]) params))))))
|
||||
|
||||
@@ -0,0 +1,276 @@
|
||||
(ns tbd.mcp.routes-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[muuntaja.core :as m]
|
||||
[tbd.todo.schema :as todo-schema]
|
||||
[malli.core :as malli]
|
||||
[tbd.oauth.core :as oauth]
|
||||
[tbd.oauth.db :as db]
|
||||
[tbd.sqlite-test :as sqlite-test]
|
||||
[tbd.oauth.routes-test :as o]
|
||||
[tbd.auth.routes-test :as t])
|
||||
(:import (java.io ByteArrayInputStream)))
|
||||
|
||||
;; The MCP handler sits behind its own transport, so these go through the real app (tbd.core)
|
||||
;; and speak JSON-RPC to /mcp the way an MCP client does, with an OAuth access token.
|
||||
|
||||
(defn- mint-token!
|
||||
"Puts a grant for `login` into the database at `path` and returns its access token, for
|
||||
tests that aren't about how a client gets one (that is tbd.oauth.routes-test)."
|
||||
[path login id & {:keys [expires-at] :or {expires-at (+ (System/currentTimeMillis) 60000)}}]
|
||||
(let [token (oauth/random-token)]
|
||||
(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- decode-body
|
||||
"The JSON-RPC message in a response body. plumcp answers a POST either with plain JSON or, when
|
||||
it decides to stream (which one is a matter of timing, so a slow CI runner sees the other), as
|
||||
Server-Sent Events: a seq of chunks whose `data:` lines hold the message. Clients accept both,
|
||||
so the tests must too."
|
||||
[{:keys [body headers]}]
|
||||
(cond
|
||||
(string? body) (m/decode "application/json" body)
|
||||
(and (some? body) (str/starts-with? (str (get headers "Content-Type")) "text/event-stream"))
|
||||
(let [data (->> (str/split-lines (if (instance? java.io.InputStream body) (slurp body) (apply str body)))
|
||||
(keep #(when (str/starts-with? % "data:") (str/trim (subs % 5))))
|
||||
(str/join "\n"))]
|
||||
(m/decode "application/json" data))
|
||||
:else body))
|
||||
|
||||
(defn- rpc
|
||||
"POST a JSON-RPC message (as data) to /mcp with `token` as the bearer token, optionally within
|
||||
the MCP session `sid`. Returns the response with its body decoded, whether plain JSON or an event
|
||||
stream (nil when there is none)."
|
||||
([app token message] (rpc app token message nil))
|
||||
([app token message sid]
|
||||
(let [body (m/encode "application/json" message)
|
||||
resp (app {:request-method :post :uri "/mcp"
|
||||
:scheme :http :server-name "localhost" :server-port 3000
|
||||
:headers (cond-> {"content-type" "application/json"
|
||||
"accept" "application/json, text/event-stream"}
|
||||
token (assoc "authorization" (str "Bearer " token))
|
||||
sid (assoc "mcp-session-id" sid))
|
||||
:body (ByteArrayInputStream. (.readAllBytes ^java.io.InputStream body))})]
|
||||
(cond-> resp
|
||||
(some? (:body resp)) (assoc :body (decode-body resp))))))
|
||||
|
||||
(defn- initialize
|
||||
"Runs the MCP handshake; returns the session id."
|
||||
[app token]
|
||||
(let [resp (rpc app token {:jsonrpc "2.0" :id 1 :method "initialize"
|
||||
:params {:protocolVersion "2025-06-18" :capabilities {}
|
||||
:clientInfo {:name "test" :version "1"}}})
|
||||
sid (get-in resp [:headers "Mcp-Session-Id"])]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= {:name "tbd" :version "1.0.0"} (select-keys (get-in resp [:body :result :serverInfo]) [:name :version])))
|
||||
(is (some? sid) "the server opens a session")
|
||||
(is (= 202 (:status (rpc app token {:jsonrpc "2.0" :method "notifications/initialized"} sid))))
|
||||
sid))
|
||||
|
||||
(defn- call-tool [app token sid tool arguments]
|
||||
(:body (rpc app token {:jsonrpc "2.0" :id 2 :method "tools/call"
|
||||
:params {:name tool :arguments arguments}}
|
||||
sid)))
|
||||
|
||||
(defn- text [result] (get-in result [:result :content 0 :text]))
|
||||
|
||||
(defn- fixture
|
||||
"An app on a fresh database, with the tokens of an admin (alice) and a regular user (bob)."
|
||||
[]
|
||||
(let [path (sqlite-test/temp-db-path)]
|
||||
{:path 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)}))
|
||||
|
||||
(deftest list-tools-test
|
||||
(let [{:keys [app alice]} (fixture)
|
||||
sid (initialize app alice)
|
||||
tools (get-in (rpc app alice {:jsonrpc "2.0" :id 2 :method "tools/list"} sid) [:body :result :tools])]
|
||||
(is (= ["add" "create_todo" "delete_todo" "get_todo" "list_todos" "ping" "update_todo" "whoami"]
|
||||
(sort (map :name tools))))
|
||||
(let [input-schema (fn [tool] (:inputSchema (first (filter #(= tool (:name %)) tools))))]
|
||||
(testing "a tool's input schema is generated from the Malli schema the HTTP API also uses"
|
||||
(let [add (input-schema "add")]
|
||||
(is (= ["x" "y"] (:required add)))
|
||||
(is (= {:x "First addend" :y "Second addend"}
|
||||
(update-vals (:properties add) :description)))
|
||||
(is (= ["number" "number"] (map :type (vals (:properties add))))))
|
||||
(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"
|
||||
(is (= {:type "object" :properties {}} (input-schema "list_todos")))))))
|
||||
|
||||
(deftest call-tool-test
|
||||
(let [{:keys [app alice]} (fixture)
|
||||
sid (initialize app alice)]
|
||||
(testing "ping"
|
||||
(is (= {:content [{:type "text" :text "pong"}] :isError false}
|
||||
(:result (call-tool app alice sid "ping" {})))))
|
||||
(testing "add goes through tbd.math.core"
|
||||
(is (= {:content [{:type "text" :text "5"}] :isError false}
|
||||
(:result (call-tool app alice sid "add" {:x 2 :y 3}))))
|
||||
(is (= "3.5" (text (call-tool app alice sid "add" {:x 1.5 :y 2})))))
|
||||
(testing "missing arguments are a tool error the model can read, not a failed request"
|
||||
(let [result (:result (call-tool app alice sid "add" {:x 2}))]
|
||||
(is (true? (:isError result)))
|
||||
(is (re-find #"Missing tool param" (get-in result [:content 0 :text])))))
|
||||
(testing "an unknown tool is a JSON-RPC error"
|
||||
(is (contains? (call-tool app alice sid "nope" {}) :error)))))
|
||||
|
||||
(deftest whoami-test
|
||||
(let [{:keys [app alice bob]} (fixture)]
|
||||
(testing "tools know which user the token belongs to, and whether they are an admin"
|
||||
(is (= "alice (Gitea user 7), admin" (text (call-tool app alice (initialize app alice) "whoami" {}))))
|
||||
(is (= "bob (Gitea user 8)" (text (call-tool app bob (initialize app bob) "whoami" {})))))))
|
||||
|
||||
(deftest authentication-test
|
||||
(let [{:keys [path app alice]} (fixture)
|
||||
metadata "resource_metadata=\"http://tbd.test/.well-known/oauth-protected-resource/mcp\""
|
||||
initialize-message {:jsonrpc "2.0" :id 1 :method "initialize"
|
||||
:params {:protocolVersion "2025-06-18" :capabilities {}
|
||||
:clientInfo {:name "test" :version "1"}}}]
|
||||
(testing "no token: 401 pointing the client at the OAuth metadata (that is how it finds where to log in)"
|
||||
(let [resp (rpc app nil initialize-message)
|
||||
challenge (get-in resp [:headers "WWW-Authenticate"])]
|
||||
(is (= 401 (:status resp)))
|
||||
(is (.startsWith ^String challenge "Bearer "))
|
||||
(is (.contains ^String challenge metadata))
|
||||
(is (not (.contains ^String challenge "error=")) "no token isn't an invalid one")
|
||||
(is (nil? (get-in resp [:headers "Mcp-Session-Id"])) "no session is opened")))
|
||||
(testing "the wrong kind of credentials"
|
||||
(doseq [authorization ["Basic YWxpY2U6cHc=" "Bearer" "Bearer " alice "bearer"]]
|
||||
(let [resp ((:app (fixture)) {:request-method :post :uri "/mcp"
|
||||
:headers {"authorization" authorization}
|
||||
:body (ByteArrayInputStream. (.getBytes "{}"))})]
|
||||
(is (= 401 (:status resp)) authorization))))
|
||||
(testing "an unknown token: 401 saying so"
|
||||
(let [resp (rpc app "not-a-token" initialize-message)
|
||||
challenge (get-in resp [:headers "WWW-Authenticate"])]
|
||||
(is (= 401 (:status resp)))
|
||||
(is (.contains ^String challenge "error=\"invalid_token\""))
|
||||
(is (.contains ^String challenge metadata))))
|
||||
(testing "a refresh token or a stored hash isn't an access token"
|
||||
(let [{:keys [tokens]} (o/get-tokens! app)]
|
||||
(is (= 401 (:status (rpc app (:refresh_token tokens) initialize-message))))
|
||||
(is (= 401 (:status (rpc app (oauth/hash-token alice) initialize-message))))))
|
||||
(testing "an expired token"
|
||||
(is (= 401 (:status (rpc app (mint-token! path "alice" 7 :expires-at (- (System/currentTimeMillis) 1000))
|
||||
initialize-message)))))
|
||||
(testing "the token is checked on every request, not only when the session is opened"
|
||||
(let [sid (initialize app alice)]
|
||||
(is (= 401 (:status (rpc app nil {:jsonrpc "2.0" :id 2 :method "tools/list"} sid))))
|
||||
(is (= 401 (:status (rpc app "not-a-token" {:jsonrpc "2.0" :id 2 :method "tools/list"} sid))))
|
||||
(is (= 401 (:status (app {:request-method :delete :uri "/mcp" :headers {"mcp-session-id" sid}}))))
|
||||
(is (= 200 (:status (rpc app alice {:jsonrpc "2.0" :id 2 :method "tools/list"} sid))))))
|
||||
(testing "and the body isn't read for a caller who isn't allowed in"
|
||||
(let [resp (app {:request-method :post :uri "/mcp" :headers {}
|
||||
:body (proxy [java.io.InputStream] [] (read ([] (throw (ex-info "body was read" {})))))})]
|
||||
(is (= 401 (:status resp)))))))
|
||||
|
||||
(deftest admin-follows-the-allowlist-test
|
||||
(let [path (sqlite-test/temp-db-path)
|
||||
token (mint-token! path "alice" 7)
|
||||
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") :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 (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))))
|
||||
(testing "and after a refresh, when the first token no longer works"
|
||||
(let [refreshed (:body (o/call app :post "/oauth/token"
|
||||
:form {"grant_type" "refresh_token" "refresh_token" (:refresh_token tokens)
|
||||
"client_id" client-id}))]
|
||||
(is (= "carol (Gitea user 9)" (whoami (:access_token refreshed))))
|
||||
(is (= 401 (:status (rpc app (:access_token tokens) {:jsonrpc "2.0" :id 1 :method "initialize"})))))))))
|
||||
|
||||
(deftest session-required-test
|
||||
(testing "tools can't be used before the handshake opens a session"
|
||||
(let [{:keys [app alice]} (fixture)
|
||||
resp (rpc app alice {:jsonrpc "2.0" :id 2 :method "tools/list"})]
|
||||
(is (<= 400 (:status resp) 499)))))
|
||||
|
||||
(deftest no-server-stream-test
|
||||
(testing "GET /mcp (the optional server-to-client SSE stream) is a 405, which MCP clients accept"
|
||||
(let [{:keys [app alice]} (fixture)
|
||||
resp (app {:request-method :get :uri "/mcp"
|
||||
:headers {"accept" "text/event-stream" "authorization" (str "Bearer " alice)}})]
|
||||
(is (= 405 (:status resp))))))
|
||||
|
||||
(deftest close-session-test
|
||||
(let [{:keys [app alice]} (fixture)
|
||||
sid (initialize app alice)]
|
||||
(is (= 202 (:status (app {:request-method :delete :uri "/mcp"
|
||||
:headers {"mcp-session-id" sid "authorization" (str "Bearer " alice)}}))))
|
||||
(testing "a closed session is gone"
|
||||
(is (= 404 (:status (rpc app alice {:jsonrpc "2.0" :id 2 :method "tools/list"} sid)))))))
|
||||
|
||||
(deftest api-unaffected-test
|
||||
(testing "the MCP route doesn't disturb the rest of the API (which it shares a router with)"
|
||||
(let [{:keys [app]} (fixture)]
|
||||
(is (= 200 (:status (app {:request-method :get :uri "/api/ping"}))))
|
||||
(is (= 200 (:status (app {:request-method :get :uri "/api/add" :query-string "x=2&y=3"})))))))
|
||||
|
||||
(deftest todo-tools-test
|
||||
;; The rules (ownership, validation, not-found) are tbd.todo.service's and tested there; this is
|
||||
;; the tools' side: arguments in, JSON out, the caller's identity passed on, errors as results.
|
||||
(let [{:keys [app alice bob]} (fixture)
|
||||
alice-sid (initialize app alice)
|
||||
bob-sid (initialize app bob)
|
||||
as-alice (partial call-tool app alice alice-sid)
|
||||
as-bob (partial call-tool app bob bob-sid)
|
||||
data (fn [resp] (m/decode "application/json" (text resp)))
|
||||
error (fn [resp] (when (true? (get-in resp [:result :isError])) (text resp)))]
|
||||
(is (= [] (data (as-alice "list_todos" {}))))
|
||||
(let [created (data (as-alice "create_todo" {:title " write tests "}))
|
||||
id (:id created)]
|
||||
(is (= {:title "write tests" :done false :owner-id 7} (select-keys created [:title :done :owner-id])))
|
||||
(is (= created (data (as-alice "get_todo" {:id id}))))
|
||||
(is (= [created] (data (as-alice "list_todos" {}))))
|
||||
(is (= {:title "ship it" :done true}
|
||||
(select-keys (data (as-alice "update_todo" {:id id :title "ship it" :done true})) [:title :done])))
|
||||
(testing "the tools act as whoever the token belongs to"
|
||||
(is (= [] (data (as-bob "list_todos" {}))))
|
||||
(is (= "todo not found" (error (as-bob "get_todo" {:id id})))))
|
||||
(testing "a service error is an error result the model can read"
|
||||
(is (= "title must not be blank" (error (as-alice "create_todo" {:title " "}))))
|
||||
(is (= "nothing to change: give a title and/or done" (error (as-alice "update_todo" {:id id})))))
|
||||
(is (= "deleted" (text (as-alice "delete_todo" {:id id}))))
|
||||
(is (= "todo not found" (error (as-alice "get_todo" {:id id})))))))
|
||||
|
||||
(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 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 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 todo-id :done "yes"})))
|
||||
(is (true? (malli/validate todo-schema/UpdateTodo {:id todo-id :done true}))))))
|
||||
@@ -0,0 +1,40 @@
|
||||
(ns tbd.nrepl.core-test
|
||||
(:require [clojure.test :refer [deftest is testing use-fixtures]]
|
||||
[tbd.nrepl.core :as nrepl])
|
||||
(:import (java.net ConnectException InetSocketAddress Socket ServerSocket)))
|
||||
|
||||
(use-fixtures :each (fn [t] (try (t) (finally (nrepl/disable!)))))
|
||||
|
||||
(defn listening? [port]
|
||||
(try (with-open [s (Socket.)]
|
||||
(.connect s (InetSocketAddress. "127.0.0.1" (int port)) 500)
|
||||
true)
|
||||
(catch java.io.IOException _ false)))
|
||||
|
||||
(deftest env-config-test
|
||||
(is (= {:port 7888 :bind "127.0.0.1"} (nrepl/env-config {})))
|
||||
(is (= {:port 7888 :bind "127.0.0.1"} (nrepl/env-config {"NREPL_PORT" " " "NREPL_BIND" ""})))
|
||||
(is (= {:port 9000 :bind "0.0.0.0"} (nrepl/env-config {"NREPL_PORT" "9000" "NREPL_BIND" "0.0.0.0"}))))
|
||||
|
||||
(deftest enable-disable-test
|
||||
(is (= {:enabled false} (nrepl/status)))
|
||||
(let [{:keys [enabled bind port] :as status} (nrepl/enable! {:port 0 :bind "127.0.0.1"})]
|
||||
(is (true? enabled))
|
||||
(is (= "127.0.0.1" bind))
|
||||
(is (pos? port) "port 0 reports the port actually bound")
|
||||
(is (= status (nrepl/status)))
|
||||
(is (listening? port))
|
||||
(testing "enabling again is a no-op"
|
||||
(is (= status (nrepl/enable! {:port 0 :bind "127.0.0.1"}))))
|
||||
(testing "disabling closes the port"
|
||||
(is (= {:enabled false} (nrepl/disable!)))
|
||||
(is (= {:enabled false} (nrepl/status)))
|
||||
(is (not (listening? port))))
|
||||
(testing "disabling again is a no-op"
|
||||
(is (= {:enabled false} (nrepl/disable!))))))
|
||||
|
||||
(deftest enable-failure-test
|
||||
(with-open [taken (ServerSocket. 0 1 (java.net.InetAddress/getByName "127.0.0.1"))]
|
||||
(is (thrown? java.net.BindException
|
||||
(nrepl/enable! {:port (.getLocalPort taken) :bind "127.0.0.1"})))
|
||||
(is (= {:enabled false} (nrepl/status)) "a failed start leaves nREPL disabled")))
|
||||
@@ -0,0 +1,118 @@
|
||||
(ns tbd.nrepl.routes-test
|
||||
(:require [clojure.test :refer [deftest is testing use-fixtures]]
|
||||
[muuntaja.core :as m]
|
||||
[tbd.auth.routes-test :as t]
|
||||
[tbd.test-util :as test-util]
|
||||
[tbd.nrepl.core :as nrepl])
|
||||
(:import (java.io ByteArrayInputStream)
|
||||
(java.net InetAddress ServerSocket)))
|
||||
|
||||
(use-fixtures :each (fn [f] (try (f) (finally (nrepl/disable!)))))
|
||||
|
||||
(defn post-nrepl
|
||||
"POST /nrepl with `body` (a string, or nil for none), as JSON unless `content-type` says otherwise.
|
||||
The handler logs each toggle; that's kept out of the test output."
|
||||
([app cookie body] (post-nrepl app cookie body "application/json"))
|
||||
([app cookie body content-type]
|
||||
(let [resp (atom nil)]
|
||||
(with-out-str
|
||||
(reset! resp (app (cond-> {:request-method :post :uri "/nrepl"
|
||||
:headers (cond-> {"content-type" content-type}
|
||||
cookie (assoc "cookie" cookie))}
|
||||
body (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))))))
|
||||
(test-util/decode-body @resp))))
|
||||
|
||||
(defn get-nrepl [app cookie]
|
||||
(let [resp (app {:request-method :get :uri "/nrepl"
|
||||
:headers (cond-> {} cookie (assoc "cookie" cookie))})]
|
||||
(test-util/decode-body resp)))
|
||||
|
||||
(deftest anonymous-test
|
||||
(let [app (t/make-app (t/gitea-stub "alice"))]
|
||||
(doseq [body ["{\"enabled\":true}" "{\"enabled\":\"junk\"}" nil]]
|
||||
(let [resp (post-nrepl app nil body)]
|
||||
(is (= 401 (:status resp)) (str "body: " body))))
|
||||
(is (= 401 (:status (get-nrepl app nil))))
|
||||
(is (= {:enabled false} (nrepl/status)) "nothing was started")))
|
||||
|
||||
(deftest non-admin-test
|
||||
(let [app (t/make-app (t/gitea-stub "mallory"))
|
||||
cookie (t/login! app)]
|
||||
(is (= 403 (:status (post-nrepl app cookie "{\"enabled\":true}"))))
|
||||
(is (= 403 (:status (get-nrepl app cookie))))
|
||||
(is (= {:enabled false} (nrepl/status)) "nothing was started")))
|
||||
|
||||
(deftest empty-allowlist-test
|
||||
(let [app (t/make-app (t/gitea-stub "alice") :admin-users #{})
|
||||
cookie (t/login! app)]
|
||||
(is (= 403 (:status (post-nrepl app cookie "{\"enabled\":true}"))))))
|
||||
|
||||
(deftest admin-test
|
||||
(let [app (t/make-app (t/gitea-stub "Alice"))
|
||||
cookie (t/login! app)]
|
||||
(testing "enable"
|
||||
(let [resp (post-nrepl app cookie "{\"enabled\":true}")]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "application/edn; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (= {:enabled true :bind "127.0.0.1"} (dissoc (:body resp) :port)))
|
||||
(is (pos? (get-in resp [:body :port])))
|
||||
(is (= (:body resp) (nrepl/status)))))
|
||||
(testing "disable"
|
||||
(let [resp (post-nrepl app cookie "{\"enabled\":false}")]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= {:enabled false} (:body resp)))
|
||||
(is (= {:enabled false} (nrepl/status)))))
|
||||
(testing "EDN bodies work too"
|
||||
(let [resp (post-nrepl app cookie "{:enabled true}" "application/edn")]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (true? (get-in resp [:body :enabled])))))))
|
||||
|
||||
(deftest status-test
|
||||
(let [app (t/make-app (t/gitea-stub "alice"))
|
||||
cookie (t/login! app)]
|
||||
(testing "off"
|
||||
(let [resp (get-nrepl app cookie)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "application/edn; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (= {:enabled false} (:body resp)))))
|
||||
(testing "on"
|
||||
(with-out-str (post-nrepl app cookie "{\"enabled\":true}"))
|
||||
(let [resp (get-nrepl app cookie)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= {:enabled true :bind "127.0.0.1"} (dissoc (:body resp) :port)))
|
||||
(is (= (:body resp) (nrepl/status)))))
|
||||
(testing "off again"
|
||||
(with-out-str (post-nrepl app cookie "{\"enabled\":false}"))
|
||||
(is (= {:enabled false} (:body (get-nrepl app cookie)))))))
|
||||
|
||||
(deftest invalid-body-test
|
||||
(let [app (t/make-app (t/gitea-stub "alice"))
|
||||
cookie (t/login! app)]
|
||||
(doseq [body [nil "{}" "{\"enabled\":\"maybe\"}" "{\"enabled\":null}" "not json"]]
|
||||
(let [resp (post-nrepl app cookie body)]
|
||||
(is (= 400 (:status resp)) (str "body: " body))
|
||||
(is (contains? (:body resp) :error) (str "body: " body))))
|
||||
(is (= {:enabled false} (nrepl/status)))))
|
||||
|
||||
(deftest bind-failure-test
|
||||
(with-open [taken (ServerSocket. 0 1 (InetAddress/getByName "127.0.0.1"))]
|
||||
(let [app (tbd.core/make-app
|
||||
{:auth {:gitea-url "https://gitea.test" :client-id "cid" :client-secret "sec"
|
||||
:redirect-uri "http://tbd.test/auth/callback" :admin-users #{"alice"}
|
||||
:session-secret "test-secret" :http (t/gitea-stub "alice")}
|
||||
:nrepl {:port (.getLocalPort taken) :bind "127.0.0.1"}})
|
||||
cookie (t/login! app)
|
||||
resp (post-nrepl app cookie "{\"enabled\":true}")]
|
||||
(is (= 500 (:status resp)))
|
||||
(is (re-find #"could not change nREPL state" (get-in resp [:body :error])))
|
||||
(is (= {:enabled false} (nrepl/status))))))
|
||||
|
||||
(deftest swagger-test
|
||||
(let [app (t/make-app (t/gitea-stub "alice"))
|
||||
spec (-> (app {:request-method :get :uri "/swagger.json" :headers {"accept" "application/json"}})
|
||||
:body
|
||||
(->> (m/decode "application/json")))
|
||||
paths (into {} (map (fn [[k v]] [(str (namespace k) "/" (name k)) v])) (:paths spec))]
|
||||
(is (contains? (get-in paths ["/nrepl"]) :post) "documented")
|
||||
(is (contains? (get-in paths ["/nrepl"]) :get) "documented")
|
||||
(is (contains? paths "/auth/login"))))
|
||||
@@ -0,0 +1,101 @@
|
||||
(ns tbd.oauth.core-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[tbd.oauth.core :as oauth]))
|
||||
|
||||
(deftest metadata-test
|
||||
(let [base "https://tbd.example.com"]
|
||||
(is (= {:resource "https://tbd.example.com/mcp"
|
||||
:authorization_servers [base]}
|
||||
(select-keys (oauth/protected-resource-metadata base) [:resource :authorization_servers])))
|
||||
(let [m (oauth/authorization-server-metadata base)]
|
||||
(is (= base (:issuer m)))
|
||||
(is (= "https://tbd.example.com/oauth/authorize" (:authorization_endpoint m)))
|
||||
(is (= "https://tbd.example.com/oauth/token" (:token_endpoint m)))
|
||||
(is (= "https://tbd.example.com/oauth/register" (:registration_endpoint m)))
|
||||
(is (= ["S256"] (:code_challenge_methods_supported m)) "PKCE is mandatory, and only S256")
|
||||
(is (= ["none"] (:token_endpoint_auth_methods_supported m)) "public clients only"))))
|
||||
|
||||
(deftest token-test
|
||||
(let [a (oauth/random-token)]
|
||||
(is (re-matches #"[A-Za-z0-9_-]{43}" a))
|
||||
(is (not= a (oauth/random-token))))
|
||||
(testing "stored form is a stable, different hex digest"
|
||||
(is (= (oauth/hash-token "abc") (oauth/hash-token "abc")))
|
||||
(is (re-matches #"[0-9a-f]{64}" (oauth/hash-token "abc")))
|
||||
(is (not= "abc" (oauth/hash-token "abc")))
|
||||
(is (not= (oauth/hash-token "abc") (oauth/hash-token "abd")))))
|
||||
|
||||
(deftest pkce-test
|
||||
;; The example from RFC 7636 appendix B.
|
||||
(let [verifier "dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
|
||||
challenge "E9Melhoa2OwvFrEMTJguCHaoeK1t8URWbuGJSstw-cM"]
|
||||
(is (= challenge (oauth/pkce-challenge verifier)))
|
||||
(is (oauth/pkce-valid? challenge verifier))
|
||||
(testing "a different verifier, or none, fails"
|
||||
(is (not (oauth/pkce-valid? challenge (str/replace verifier "d" "e"))))
|
||||
(is (not (oauth/pkce-valid? challenge nil))))
|
||||
(testing "the challenge itself is not a verifier, and a too-short verifier is refused"
|
||||
(is (not (oauth/pkce-valid? challenge challenge)))
|
||||
(is (not (oauth/pkce-valid? (oauth/pkce-challenge "short") "short"))))
|
||||
(is (oauth/challenge-format? challenge))
|
||||
(is (not (oauth/challenge-format? "too-short")))
|
||||
(is (not (oauth/challenge-format? nil)))))
|
||||
|
||||
(deftest valid-redirect-uri-test
|
||||
(doseq [ok ["https://client.example.com/callback"
|
||||
"http://localhost:8080/callback"
|
||||
"http://127.0.0.1/cb"
|
||||
"http://[::1]:9000/cb"
|
||||
"cursor://anysphere.cursor-retrieval/oauth/callback"]]
|
||||
(is (oauth/valid-redirect-uri? ok) ok))
|
||||
(doseq [bad ["http://client.example.com/callback" ; plain http off the local machine
|
||||
"http://localhost.evil.com/cb"
|
||||
"javascript:alert(1)"
|
||||
"data:text/html,hi"
|
||||
"file:///etc/passwd"
|
||||
"https://client.example.com/cb#frag"
|
||||
"https://user:pw@client.example.com/cb"
|
||||
"https:///nohost"
|
||||
"/relative/path"
|
||||
"not a uri"
|
||||
""
|
||||
nil
|
||||
42
|
||||
(str "https://client.example.com/" (apply str (repeat 2100 "a")))]]
|
||||
(is (not (oauth/valid-redirect-uri? bad)) (pr-str bad))))
|
||||
|
||||
(deftest redirect-uri-matches-test
|
||||
(is (oauth/redirect-uri-matches? "https://c.example.com/cb" "https://c.example.com/cb"))
|
||||
(is (not (oauth/redirect-uri-matches? "https://c.example.com/cb" "https://c.example.com/cb2")))
|
||||
(is (not (oauth/redirect-uri-matches? "https://c.example.com/cb" "https://c.example.com/cb/")))
|
||||
(is (not (oauth/redirect-uri-matches? "https://c.example.com/cb" "https://c.example.com/cb?x=1")))
|
||||
(is (not (oauth/redirect-uri-matches? "https://c.example.com/cb" nil)))
|
||||
(testing "a client on the local machine picks its own port"
|
||||
(is (oauth/redirect-uri-matches? "http://localhost/cb" "http://localhost:53682/cb"))
|
||||
(is (oauth/redirect-uri-matches? "http://127.0.0.1:1/cb" "http://127.0.0.1:2/cb"))
|
||||
(is (not (oauth/redirect-uri-matches? "http://localhost/cb" "http://localhost:53682/other")))
|
||||
(is (not (oauth/redirect-uri-matches? "http://localhost/cb" "http://127.0.0.1:53682/cb")))
|
||||
(is (not (oauth/redirect-uri-matches? "https://c.example.com/cb" "https://c.example.com:8443/cb")) "only loopback")))
|
||||
|
||||
(deftest redirect-with-test
|
||||
(is (= "https://c.example.com/cb?code=a+b&state=s"
|
||||
(oauth/redirect-with "https://c.example.com/cb" {:code "a b" :state "s"})))
|
||||
(is (= "https://c.example.com/cb?x=1&code=c"
|
||||
(oauth/redirect-with "https://c.example.com/cb?x=1" {:code "c"})))
|
||||
(is (= "https://c.example.com/cb?code=c" (oauth/redirect-with "https://c.example.com/cb" {:code "c" :state nil}))
|
||||
"absent values are dropped"))
|
||||
|
||||
(deftest scope-and-resource-test
|
||||
(is (= "mcp" (oauth/parse-scope nil)))
|
||||
(is (= "mcp" (oauth/parse-scope "")))
|
||||
(is (= "mcp" (oauth/parse-scope " mcp ")))
|
||||
(is (nil? (oauth/parse-scope "mcp admin")))
|
||||
(is (nil? (oauth/parse-scope "admin")))
|
||||
(let [base "https://tbd.example.com"]
|
||||
(is (oauth/resource-ok? base nil) "the parameter is optional")
|
||||
(is (oauth/resource-ok? base "https://tbd.example.com/mcp"))
|
||||
(is (oauth/resource-ok? base "https://tbd.example.com/mcp/"))
|
||||
(is (oauth/resource-ok? base ["https://tbd.example.com/mcp"]))
|
||||
(is (not (oauth/resource-ok? base "https://other.example.com/mcp")))
|
||||
(is (not (oauth/resource-ok? base ["https://tbd.example.com/mcp" "https://other.example.com/mcp"])))))
|
||||
@@ -0,0 +1,111 @@
|
||||
(ns tbd.oauth.db-test
|
||||
(:require [clojure.java.io :as io]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[next.jdbc :as jdbc]
|
||||
[tbd.oauth.db :as db]
|
||||
[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})
|
||||
|
||||
(defn grant [n]
|
||||
{:client-id "c1" :user-id 7 :login "alice" :scope "mcp"
|
||||
:access-hash (str "access-" n) :access-expires-at 2000
|
||||
:refresh-hash (str "refresh-" n) :refresh-expires-at 9000
|
||||
:created-at 1000})
|
||||
|
||||
(deftest open-test
|
||||
(testing "creates the file and its directory"
|
||||
(let [path (temp-db-path)]
|
||||
(db/open path)
|
||||
(is (.exists (io/file path)))))
|
||||
(testing "no path is an error, not a database in the working directory"
|
||||
(is (thrown? clojure.lang.ExceptionInfo (db/open nil)))))
|
||||
|
||||
(deftest client-test
|
||||
(let [ds (db/open (temp-db-path))]
|
||||
(is (nil? (db/find-client ds "c1")))
|
||||
(db/insert-client! ds (client "c1" 1000))
|
||||
(is (= (client "c1" 1000) (db/find-client ds "c1")) "redirect URIs come back as a vector of strings")))
|
||||
|
||||
(deftest code-test
|
||||
(let [ds (db/open (temp-db-path))
|
||||
code {:hash "h1" :client-id "c1" :user-id 7 :login "alice" :redirect-uri "https://c.example.com/cb"
|
||||
:code-challenge "chal" :scope "mcp" :expires-at 5000}]
|
||||
(db/insert-code! ds code)
|
||||
(is (= code (db/take-code! ds "h1")) "the stored row comes back")
|
||||
(testing "a code can be taken once"
|
||||
(is (nil? (db/take-code! ds "h1"))))
|
||||
(is (nil? (db/take-code! ds "unknown")))))
|
||||
|
||||
(deftest grant-test
|
||||
(let [ds (db/open (temp-db-path))]
|
||||
(db/insert-grant! ds (grant 1))
|
||||
(testing "found by access token until it expires"
|
||||
(is (= "alice" (:login (db/find-grant-by-access ds "access-1" 1999))))
|
||||
(is (nil? (db/find-grant-by-access ds "access-1" 2000)))
|
||||
(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"))
|
||||
fresh {:access-hash "access-2" :access-expires-at 3000 :refresh-hash "refresh-2" :refresh-expires-at 9500}]
|
||||
(is (= "access-2" (:access-hash (db/rotate-grant! ds id "refresh-1" fresh))))
|
||||
(is (nil? (db/find-grant-by-access ds "access-1" 1000)))
|
||||
(is (nil? (db/find-grant-by-refresh ds "refresh-1")))
|
||||
(is (nil? (db/rotate-grant! ds id "refresh-1" (assoc fresh :access-hash "access-3" :refresh-hash "refresh-3")))
|
||||
"the old refresh token can't rotate it again")
|
||||
(is (some? (db/find-grant-by-access ds "access-2" 1000)))))
|
||||
(testing "deleting revokes"
|
||||
(db/delete-grant! ds (:id (db/find-grant-by-refresh ds "refresh-2")))
|
||||
(is (nil? (db/find-grant-by-access ds "access-2" 1000))))))
|
||||
|
||||
(deftest prune-test
|
||||
(let [ds (db/open (temp-db-path))
|
||||
code #(hash-map :hash %1 :client-id "used" :user-id 1 :login "a" :redirect-uri "x"
|
||||
:code-challenge "c" :scope "mcp" :expires-at %2)]
|
||||
(doseq [c [(client "old-unused" 100) (client "new-unused" 900) (client "old-used" 100) (client "old-pending" 100)]]
|
||||
(db/insert-client! ds c))
|
||||
(db/insert-grant! ds (assoc (grant 1) :client-id "old-used"))
|
||||
(db/insert-grant! ds (assoc (grant 2) :client-id "old-used" :refresh-expires-at 900))
|
||||
(db/insert-code! ds (assoc (code "pending" 5000) :client-id "old-pending"))
|
||||
(db/insert-code! ds (code "expired" 500))
|
||||
(db/prune! ds 1000 500)
|
||||
(is (nil? (db/find-client ds "old-unused")) "registered long ago and never approved")
|
||||
(is (some? (db/find-client ds "new-unused")) "recent registrations get time to be used")
|
||||
(is (some? (db/find-client ds "old-used")) "clients with a grant stay")
|
||||
(is (some? (db/find-client ds "old-pending")) "clients with an outstanding code stay")
|
||||
(is (some? (db/find-grant-by-refresh ds "refresh-1")) "a grant that can still be refreshed stays")
|
||||
(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})))))))
|
||||
@@ -0,0 +1,379 @@
|
||||
(ns tbd.oauth.routes-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[muuntaja.core :as m]
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.auth.routes-test :as t]
|
||||
[tbd.oauth.core :as oauth]
|
||||
[tbd.oauth.db :as db]
|
||||
[tbd.sqlite-test :as sqlite-test]
|
||||
[tbd.test-util :as test-util])
|
||||
(:import (java.io ByteArrayInputStream)
|
||||
(java.net URLDecoder)))
|
||||
|
||||
;; These go through the real app with Gitea stubbed out, the way an MCP client and a browser
|
||||
;; would: discovery, registration, login + consent in the browser, then the token endpoint.
|
||||
|
||||
(def redirect-uri "http://localhost:8123/callback")
|
||||
(def verifier "dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk")
|
||||
(def challenge (oauth/pkce-challenge verifier))
|
||||
|
||||
(defn json-str [data] (slurp (m/encode "application/json" data)))
|
||||
|
||||
(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) :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."
|
||||
[app method uri & {:keys [cookie headers body form query]}]
|
||||
(let [payload (or (some-> form auth/form-encode) body)
|
||||
content-type (cond form "application/x-www-form-urlencoded" body "application/json")]
|
||||
(test-util/decode-body
|
||||
(app (cond-> {:request-method method :uri uri :query-string query :headers (or headers {})}
|
||||
cookie (assoc-in [:headers "cookie"] cookie)
|
||||
payload (assoc :body (ByteArrayInputStream. (.getBytes ^String payload "UTF-8")))
|
||||
content-type (assoc-in [:headers "content-type"] content-type))))))
|
||||
|
||||
(defn query-params
|
||||
"The query parameters of a response's Location header, decoded."
|
||||
[resp]
|
||||
(let [location (get-in resp [:headers "Location"] "")]
|
||||
(into {} (for [pair (str/split (or (second (str/split location #"\?" 2)) "") #"&")
|
||||
:when (seq pair)
|
||||
:let [[k v] (str/split pair #"=" 2)]]
|
||||
[(URLDecoder/decode ^String k "UTF-8") (URLDecoder/decode ^String (or v "") "UTF-8")]))))
|
||||
|
||||
(defn register!
|
||||
"Registers a client; returns its client_id."
|
||||
([app] (register! app {}))
|
||||
([app metadata]
|
||||
(:client_id (:body (call app :post "/oauth/register"
|
||||
:body (json-str (merge {:redirect_uris [redirect-uri] :client_name "Test client"} metadata)))))))
|
||||
|
||||
(defn authorize-params [client-id & {:as overrides}]
|
||||
(merge {"client_id" client-id "redirect_uri" redirect-uri "response_type" "code"
|
||||
"code_challenge" challenge "code_challenge_method" "S256" "state" "st-1" "scope" "mcp"}
|
||||
overrides))
|
||||
|
||||
(defn consent!
|
||||
"Opens the consent page as the logged-in `cookie`; returns {:page :cookie :csrf}."
|
||||
[app cookie params]
|
||||
(let [page (call app :get "/oauth/authorize" :cookie cookie :query (auth/form-encode params))]
|
||||
{:page page
|
||||
:cookie (or (t/set-cookie page) cookie)
|
||||
:csrf (second (re-find #"name=\"csrf\" value=\"([^\"]+)\"" (str (:body page))))}))
|
||||
|
||||
(defn decide!
|
||||
"Submits the consent form (`decision` approve or deny); returns the response."
|
||||
[app {:keys [cookie csrf]} params decision]
|
||||
(call app :post "/oauth/authorize" :cookie cookie :form (assoc params "csrf" csrf "decision" decision)))
|
||||
|
||||
(defn token!
|
||||
"Exchanges an authorization code (with the right verifier and redirect URI unless overridden)."
|
||||
[app client-id code & {:as overrides}]
|
||||
(call app :post "/oauth/token"
|
||||
:form (merge {"grant_type" "authorization_code" "code" code "client_id" client-id
|
||||
"redirect_uri" redirect-uri "code_verifier" verifier}
|
||||
overrides)))
|
||||
|
||||
(defn authorize-code!
|
||||
"The whole browser half for a logged-in user: consent page, then Approve. Returns the code."
|
||||
[app cookie client-id]
|
||||
(let [params (authorize-params client-id)
|
||||
resp (decide! app (consent! app cookie params) params "approve")]
|
||||
(get (query-params resp) "code")))
|
||||
|
||||
(defn get-tokens!
|
||||
"The whole flow, from an empty database to a token response body. Returns {:client-id :tokens :cookie}."
|
||||
[app]
|
||||
(let [client-id (register! app)
|
||||
cookie (t/login! app)
|
||||
code (authorize-code! app cookie client-id)]
|
||||
{:client-id client-id :cookie cookie :tokens (:body (token! app client-id code))}))
|
||||
|
||||
(deftest discovery-test
|
||||
(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)]
|
||||
(is (= 200 (:status resp)) uri)
|
||||
(is (= {:resource "http://tbd.test/mcp" :authorization_servers ["http://tbd.test"]}
|
||||
(select-keys (:body resp) [:resource :authorization_servers]))))))
|
||||
(testing "authorization server metadata"
|
||||
(let [resp (call app :get "/.well-known/oauth-authorization-server")]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "http://tbd.test" (get-in resp [:body :issuer])))
|
||||
(is (= "http://tbd.test/oauth/register" (get-in resp [:body :registration_endpoint])))))
|
||||
(testing "JSON whatever the Accept header says (the API default is EDN)"
|
||||
(is (= "application/json" (get-in (call app :get "/.well-known/oauth-authorization-server"
|
||||
:headers {"accept" "application/edn"})
|
||||
[:headers "Content-Type"]))))))
|
||||
|
||||
(deftest unconfigured-test
|
||||
(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"]
|
||||
[:get "/oauth/authorize"]
|
||||
[:post "/oauth/authorize"]
|
||||
[:post "/oauth/token"]]]
|
||||
(is (= 503 (:status (call app method uri))) (str method " " uri)))))
|
||||
|
||||
(deftest register-test
|
||||
(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"
|
||||
:body (json-str {:redirect_uris [redirect-uri "https://c.example.com/cb"] :client_name "Claude"
|
||||
:grant_types ["authorization_code" "refresh_token"] :response_types ["code"]
|
||||
:token_endpoint_auth_method "none" :scope "ignored"}))
|
||||
client (:body resp)]
|
||||
(is (= 201 (:status resp)))
|
||||
(is (= "no-store" (get-in resp [:headers "Cache-Control"])))
|
||||
(is (some? (:client_id client)))
|
||||
(is (= "Claude" (:client_name client)))
|
||||
(is (= [redirect-uri "https://c.example.com/cb"] (:redirect_uris client)))
|
||||
(is (= "none" (:token_endpoint_auth_method client)))
|
||||
(is (nil? (:client_secret client)))
|
||||
(is (= "Claude" (:name (db/find-client (db/open path) (:client_id client)))) "and it is stored")))
|
||||
(testing "the name is optional, trimmed and capped"
|
||||
(is (= "Unnamed application" (get-in (call app :post "/oauth/register" :body (json-str {:redirect_uris [redirect-uri]}))
|
||||
[:body :client_name])))
|
||||
(is (= 100 (count (get-in (call app :post "/oauth/register"
|
||||
:body (json-str {:redirect_uris [redirect-uri] :client_name (apply str (repeat 500 "x"))}))
|
||||
[:body :client_name])))))
|
||||
(testing "bad registrations are refused with an RFC 7591 error"
|
||||
(doseq [[why body error]
|
||||
[["no body" nil "invalid_client_metadata"]
|
||||
["not JSON" "nope" "invalid_client_metadata"]
|
||||
["not an object" "[1]" "invalid_client_metadata"]
|
||||
["no redirect_uris" (json-str {:client_name "x"}) "invalid_client_metadata"]
|
||||
["empty redirect_uris" (json-str {:redirect_uris []}) "invalid_client_metadata"]
|
||||
["redirect_uris of the wrong type" (json-str {:redirect_uris [42]}) "invalid_client_metadata"]
|
||||
["too many redirect_uris" (json-str {:redirect_uris (repeat 11 redirect-uri)}) "invalid_client_metadata"]
|
||||
["http off the local machine" (json-str {:redirect_uris ["http://evil.example.com/cb"]}) "invalid_redirect_uri"]
|
||||
["javascript: URI" (json-str {:redirect_uris ["javascript:alert(1)"]}) "invalid_redirect_uri"]
|
||||
["one bad URI among good ones" (json-str {:redirect_uris [redirect-uri "http://evil.example.com/cb"]}) "invalid_redirect_uri"]
|
||||
["a confidential client" (json-str {:redirect_uris [redirect-uri] :token_endpoint_auth_method "client_secret_basic"})
|
||||
"invalid_client_metadata"]
|
||||
["an unsupported grant type" (json-str {:redirect_uris [redirect-uri] :grant_types ["password"]}) "invalid_client_metadata"]
|
||||
["an unsupported response type" (json-str {:redirect_uris [redirect-uri] :response_types ["token"]}) "invalid_client_metadata"]
|
||||
["an oversized body" (json-str {:redirect_uris [redirect-uri] :client_name (apply str (repeat 20000 "x"))})
|
||||
"invalid_client_metadata"]]]
|
||||
(let [resp (call app :post "/oauth/register" :body body)]
|
||||
(is (= 400 (:status resp)) why)
|
||||
(is (= error (get-in resp [:body :error])) why))))))
|
||||
|
||||
(deftest authorize-request-errors-test
|
||||
(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)))]
|
||||
(testing "an unknown client or an unregistered redirect URI is shown to the user, never redirected to"
|
||||
(doseq [params [(authorize-params "nope")
|
||||
(authorize-params nil)
|
||||
(authorize-params client-id "redirect_uri" "https://evil.example.com/cb")
|
||||
(authorize-params client-id "redirect_uri" "http://localhost:8123/other")
|
||||
(dissoc (authorize-params client-id) "redirect_uri")]]
|
||||
(let [resp (open params)]
|
||||
(is (= 400 (:status resp)) (pr-str params))
|
||||
(is (nil? (get-in resp [:headers "Location"])))
|
||||
(is (str/includes? (get-in resp [:headers "Content-Type"]) "text/html")))))
|
||||
(testing "any other problem goes back to the client's redirect URI, with its state"
|
||||
(doseq [[why params error]
|
||||
[["response_type token" (authorize-params client-id "response_type" "token") "unsupported_response_type"]
|
||||
["no PKCE" (dissoc (authorize-params client-id) "code_challenge" "code_challenge_method") "invalid_request"]
|
||||
["plain PKCE" (authorize-params client-id "code_challenge_method" "plain") "invalid_request"]
|
||||
["a malformed challenge" (authorize-params client-id "code_challenge" "short") "invalid_request"]
|
||||
["an unknown scope" (authorize-params client-id "scope" "mcp admin") "invalid_scope"]
|
||||
["another resource" (authorize-params client-id "resource" "https://other.example.com/mcp") "invalid_target"]]]
|
||||
(let [resp (open params)
|
||||
back (query-params resp)]
|
||||
(is (= 303 (:status resp)) why)
|
||||
(is (str/starts-with? (get-in resp [:headers "Location"]) (str redirect-uri "?")) why)
|
||||
(is (= error (get back "error")) why)
|
||||
(is (= "st-1" (get back "state")) why)
|
||||
(is (= "http://tbd.test" (get back "iss")) why))))
|
||||
(testing "a loopback client may use a different port"
|
||||
(is (= 200 (:status (open (authorize-params client-id "redirect_uri" "http://localhost:54321/callback"))))))
|
||||
(testing "the resource parameter is accepted when it is this server"
|
||||
(is (= 200 (:status (open (authorize-params client-id "resource" "http://tbd.test/mcp"))))))
|
||||
(testing "repeated parameters aren't an error, they just don't count"
|
||||
(is (= 400 (:status (call app :get "/oauth/authorize" :cookie cookie
|
||||
:query (str "client_id=" client-id "&client_id=" client-id))))))))
|
||||
|
||||
(deftest login-then-consent-test
|
||||
(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"
|
||||
(let [resp (call app :get "/oauth/authorize" :query query)
|
||||
login (get-in resp [:headers "Location"])]
|
||||
(is (= 302 (:status resp)))
|
||||
(is (str/starts-with? login "/auth/login?return_to="))
|
||||
(let [start (call app :get "/auth/login" :query (second (str/split login #"\?" 2)))
|
||||
done (call app :get "/auth/callback" :cookie (t/set-cookie start)
|
||||
:query (str "code=abc&state=" (t/location-state start)))]
|
||||
(is (= (str "/oauth/authorize?" query) (get-in done [:headers "Location"])))
|
||||
(testing "where the consent page is now shown"
|
||||
(let [page (call app :get "/oauth/authorize" :cookie (t/set-cookie done) :query query)]
|
||||
(is (= 200 (:status page)))
|
||||
(is (str/includes? (:body page) "Test client")))))))))
|
||||
|
||||
(deftest consent-page-test
|
||||
(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)))
|
||||
(testing "shows who, what for and where to, escaping what the client chose"
|
||||
(is (str/includes? (:body page) "<script>alert(1)</script>"))
|
||||
(is (not (str/includes? (:body page) "<script>")))
|
||||
(is (str/includes? (:body page) "alice"))
|
||||
(is (str/includes? (:body page) redirect-uri)))
|
||||
(testing "carries a CSRF token, and the request it will approve"
|
||||
(is (some? csrf))
|
||||
(doseq [k ["client_id" "redirect_uri" "code_challenge" "state"]]
|
||||
(is (str/includes? (:body page) (str "name=\"" k "\"")) k)))
|
||||
(testing "can't be framed or cached"
|
||||
(is (= "DENY" (get-in page [:headers "X-Frame-Options"])))
|
||||
(is (str/includes? (get-in page [:headers "Content-Security-Policy"]) "frame-ancestors 'none'"))
|
||||
(is (= "no-store" (get-in page [:headers "Cache-Control"]))))))
|
||||
|
||||
(deftest consent-decision-test
|
||||
(let [app (app-for (sqlite-test/temp-db-path))
|
||||
client-id (register! app)
|
||||
params (authorize-params client-id)
|
||||
cookie (t/login! app)]
|
||||
(testing "approving redirects to the client with a code, the client's state, and the issuer"
|
||||
(let [resp (decide! app (consent! app cookie params) params "approve")
|
||||
back (query-params resp)]
|
||||
(is (= 303 (:status resp)))
|
||||
(is (str/starts-with? (get-in resp [:headers "Location"]) (str redirect-uri "?")))
|
||||
(is (re-matches #"[A-Za-z0-9_-]{43}" (get back "code")))
|
||||
(is (= "st-1" (get back "state")))
|
||||
(is (= "http://tbd.test" (get back "iss")))))
|
||||
(testing "denying redirects with access_denied and no code"
|
||||
(let [back (query-params (decide! app (consent! app cookie params) params "deny"))]
|
||||
(is (= "access_denied" (get back "error")))
|
||||
(is (= "st-1" (get back "state")))
|
||||
(is (nil? (get back "code")))))
|
||||
(testing "anything but approve is a denial"
|
||||
(is (= "access_denied" (get (query-params (decide! app (consent! app cookie params) params "whatever")) "error"))))
|
||||
(testing "without the CSRF token, or with someone else's, nothing is approved"
|
||||
(let [consent (consent! app cookie params)]
|
||||
(doseq [csrf [nil "" "wrong"]]
|
||||
(let [resp (decide! app (assoc consent :csrf csrf) params "approve")]
|
||||
(is (= 400 (:status resp)) (pr-str csrf))
|
||||
(is (nil? (get-in resp [:headers "Location"])))))
|
||||
(testing "or when the form comes from a session that never saw the consent page"
|
||||
(is (= 400 (:status (decide! app (assoc consent :cookie cookie) params "approve")))))))
|
||||
(testing "logged out, the form does nothing"
|
||||
(let [consent (consent! app cookie params)
|
||||
resp (decide! app (assoc consent :cookie nil) params "approve")]
|
||||
(is (= 401 (:status resp)))
|
||||
(is (nil? (get-in resp [:headers "Location"])))))
|
||||
(testing "the request is checked again: it can't be swapped for another after the page was shown"
|
||||
(let [consent (consent! app cookie params)
|
||||
resp (decide! app consent (assoc params "redirect_uri" "https://evil.example.com/cb") "approve")]
|
||||
(is (= 400 (:status resp)))
|
||||
(is (nil? (get-in resp [:headers "Location"])))))))
|
||||
|
||||
(deftest code-exchange-test
|
||||
(let [path (sqlite-test/temp-db-path)
|
||||
app (app-for path)
|
||||
client-id (register! app)
|
||||
other-client-id (register! app)
|
||||
cookie (t/login! app)
|
||||
fresh-code #(authorize-code! app cookie client-id)]
|
||||
(testing "a good exchange returns tokens for the user who approved"
|
||||
(let [resp (token! app client-id (fresh-code))
|
||||
{:keys [access_token refresh_token token_type expires_in scope]} (:body resp)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "no-store" (get-in resp [:headers "Cache-Control"])))
|
||||
(is (= "Bearer" token_type))
|
||||
(is (= 3600 expires_in))
|
||||
(is (= "mcp" scope))
|
||||
(is (not= access_token refresh_token))
|
||||
(let [grant (db/find-grant-by-access (db/open path) (oauth/hash-token access_token) (System/currentTimeMillis))]
|
||||
(is (= {:login "alice" :user-id 7 :client-id client-id :scope "mcp"}
|
||||
(select-keys grant [:login :user-id :client-id :scope])))
|
||||
(is (not (str/includes? (pr-str grant) access_token)) "only a hash is stored")
|
||||
(is (not (str/includes? (pr-str grant) refresh_token))))))
|
||||
(testing "a code works once"
|
||||
(let [code (fresh-code)]
|
||||
(is (= 200 (:status (token! app client-id code))))
|
||||
(let [resp (token! app client-id code)]
|
||||
(is (= 400 (:status resp)))
|
||||
(is (= "invalid_grant" (get-in resp [:body :error]))))))
|
||||
(testing "anything wrong with the request is invalid_grant, and burns the code"
|
||||
(doseq [[why overrides] [["wrong verifier" {"code_verifier" (apply str (repeat 43 "a"))}]
|
||||
["a too-short verifier" {"code_verifier" "short"}]
|
||||
["wrong redirect_uri" {"redirect_uri" "http://localhost:8123/other"}]
|
||||
["another client's id" {"client_id" other-client-id}]]]
|
||||
(let [code (fresh-code)
|
||||
resp (apply token! app (get overrides "client_id" client-id) code (mapcat identity (dissoc overrides "client_id")))]
|
||||
(is (= 400 (:status resp)) why)
|
||||
(is (= "invalid_grant" (get-in resp [:body :error])) why)
|
||||
(is (= "invalid_grant" (get-in (token! app client-id code) [:body :error])) (str why ", then right")))))
|
||||
(testing "an expired code"
|
||||
(db/insert-code! (db/open path) {:hash (oauth/hash-token "old") :client-id client-id :user-id 7 :login "alice"
|
||||
:redirect-uri redirect-uri :code-challenge challenge :scope "mcp" :expires-at 1})
|
||||
(is (= "invalid_grant" (get-in (token! app client-id "old") [:body :error]))))
|
||||
(testing "an unknown code"
|
||||
(is (= "invalid_grant" (get-in (token! app client-id "nope") [:body :error]))))
|
||||
(testing "an unknown client"
|
||||
(is (= "invalid_client" (get-in (token! app "nope" (fresh-code)) [:body :error]))))
|
||||
(testing "missing parameters"
|
||||
(doseq [k ["code" "code_verifier" "redirect_uri" "client_id"]]
|
||||
(let [resp (call app :post "/oauth/token"
|
||||
:form (dissoc {"grant_type" "authorization_code" "code" "c" "client_id" client-id
|
||||
"redirect_uri" redirect-uri "code_verifier" verifier}
|
||||
k))]
|
||||
(is (= "invalid_request" (get-in resp [:body :error])) k))))
|
||||
(testing "other grant types and formats"
|
||||
(is (= "unsupported_grant_type" (get-in (call app :post "/oauth/token" :form {"grant_type" "password"}) [:body :error])))
|
||||
(is (= "unsupported_grant_type" (get-in (call app :post "/oauth/token" :body (json-str {:grant_type "authorization_code"}))
|
||||
[:body :error]))
|
||||
"the token endpoint takes forms, as RFC 6749 says"))))
|
||||
|
||||
(deftest refresh-test
|
||||
(let [path (sqlite-test/temp-db-path)
|
||||
app (app-for path)
|
||||
{:keys [client-id tokens]} (get-tokens! app)
|
||||
refresh! (fn [refresh-token & {:as overrides}]
|
||||
(call app :post "/oauth/token"
|
||||
:form (merge {"grant_type" "refresh_token" "refresh_token" refresh-token "client_id" client-id}
|
||||
overrides)))
|
||||
live? (fn [access-token] (some? (db/find-grant-by-access (db/open path) (oauth/hash-token access-token)
|
||||
(System/currentTimeMillis))))
|
||||
resp (refresh! (:refresh_token tokens))
|
||||
fresh (:body resp)]
|
||||
(testing "a refresh token yields a new pair, and the old pair stops working"
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "Bearer" (:token_type fresh)))
|
||||
(is (= "mcp" (:scope fresh)))
|
||||
(is (not= (:access_token tokens) (:access_token fresh)))
|
||||
(is (not= (:refresh_token tokens) (:refresh_token fresh)))
|
||||
(is (live? (:access_token fresh)))
|
||||
(is (not (live? (:access_token tokens)))))
|
||||
(testing "the old refresh token is used up"
|
||||
(let [reuse (refresh! (:refresh_token tokens))]
|
||||
(is (= 400 (:status reuse)))
|
||||
(is (= "invalid_grant" (get-in reuse [:body :error])))))
|
||||
(testing "a refresh token is only good for the client it was issued to, and asking wrongly doesn't spend it"
|
||||
(let [other (register! app)]
|
||||
(is (= "invalid_grant" (get-in (refresh! (:refresh_token fresh) "client_id" other) [:body :error])))
|
||||
(is (= 200 (:status (refresh! (:refresh_token fresh)))))))
|
||||
(testing "an expired refresh token is refused, and the grant is gone"
|
||||
(db/insert-grant! (db/open path) {:client-id client-id :user-id 7 :login "alice" :scope "mcp"
|
||||
:access-hash "a" :access-expires-at 1
|
||||
:refresh-hash (oauth/hash-token "stale") :refresh-expires-at 1 :created-at 1})
|
||||
(is (= "invalid_grant" (get-in (refresh! "stale") [:body :error])))
|
||||
(is (nil? (db/find-grant-by-refresh (db/open path) (oauth/hash-token "stale")))))
|
||||
(testing "missing or unknown refresh tokens"
|
||||
(is (= "invalid_request" (get-in (call app :post "/oauth/token" :form {"grant_type" "refresh_token" "client_id" client-id})
|
||||
[:body :error])))
|
||||
(is (= "invalid_grant" (get-in (refresh! "unknown") [:body :error]))))))
|
||||
@@ -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")))))))
|
||||
@@ -0,0 +1,14 @@
|
||||
(ns tbd.test-util
|
||||
(:require [clojure.string :as str]
|
||||
[muuntaja.core :as m]
|
||||
[tbd.http :as http]))
|
||||
|
||||
(defn decode-body
|
||||
"Reads a response's body back into data by the response's own Content-Type (JSON, EDN or
|
||||
Transit). Bodies that aren't one of those, like text/plain, are left alone."
|
||||
[resp]
|
||||
(let [content-type (get-in resp [:headers "Content-Type"] "")
|
||||
body (:body resp)]
|
||||
(if (and body (not (string? body)) (re-find #"json|edn|transit" content-type))
|
||||
(update resp :body #(m/decode http/muuntaja (first (str/split content-type #";")) %))
|
||||
resp)))
|
||||
@@ -0,0 +1,41 @@
|
||||
(ns tbd.todo.core-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[tbd.todo.core :as todo]))
|
||||
|
||||
(deftest validate-title-test
|
||||
(testing "trims"
|
||||
(is (= {:ok "buy milk"} (todo/validate-title " buy milk\n"))))
|
||||
(testing "blank or missing"
|
||||
(doseq [title [nil "" " " "\t\n"]]
|
||||
(is (= {:error "title must not be blank"} (todo/validate-title title)) (pr-str title))))
|
||||
(testing "length is checked after trimming"
|
||||
(let [longest (apply str (repeat todo/max-title-length "x"))]
|
||||
(is (= {:ok longest} (todo/validate-title (str " " longest " "))))
|
||||
(is (contains? (todo/validate-title (str longest "x")) :error)))))
|
||||
|
||||
(deftest new-todo-test
|
||||
(is (= {:ok {:owner-id 7 :title "buy milk" :done false :created-at 1000 :updated-at 1000}}
|
||||
(todo/new-todo 7 " buy milk " 1000)))
|
||||
(is (= {:error "title must not be blank"} (todo/new-todo 7 " " 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"
|
||||
(is (= {:ok (assoc stored :title "buy oat milk" :updated-at 2000)}
|
||||
(todo/apply-changes stored {:title " buy oat milk "} 2000))))
|
||||
(testing "done, both ways"
|
||||
(let [done (:ok (todo/apply-changes stored {:done true} 2000))]
|
||||
(is (= (assoc stored :done true :updated-at 2000) done))
|
||||
(is (= (assoc stored :updated-at 3000) (:ok (todo/apply-changes done {:done false} 3000))))))
|
||||
(testing "both at once"
|
||||
(is (= {:ok (assoc stored :title "x" :done true :updated-at 2000)}
|
||||
(todo/apply-changes stored {:title "x" :done true} 2000))))
|
||||
(testing "an invalid title changes nothing"
|
||||
(is (= {:error "title must not be blank"} (todo/apply-changes stored {:title " " :done true} 2000))))
|
||||
(testing "only :title and :done can change; the rest of the todo is untouched"
|
||||
(is (= {:ok (assoc stored :done true :updated-at 2000)}
|
||||
(todo/apply-changes stored {:done true :id 99 :owner-id 8 :created-at 0} 2000))))
|
||||
(testing "no changes"
|
||||
(doseq [changes [{} {:id 99} nil]]
|
||||
(is (contains? (todo/apply-changes stored changes 2000) :error) (pr-str changes)))))
|
||||
@@ -0,0 +1,96 @@
|
||||
(ns tbd.todo.db-test
|
||||
(:require [clojure.java.io :as io]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[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 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)
|
||||
saved (db/insert! (db/open path) (todo 7 "buy milk"))]
|
||||
(is (= [saved] (db/list-todos (db/open path) 7)))))
|
||||
(testing "a path is required"
|
||||
(doseq [path [nil "" " "]]
|
||||
(is (thrown? clojure.lang.ExceptionInfo (db/open path))))))
|
||||
|
||||
(deftest crud-test
|
||||
(let [ds (db/open (temp-db-path))
|
||||
saved (db/insert! ds (todo 7 "buy milk"))
|
||||
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)))
|
||||
(is (= ["buy milk" "walk dog"] (map :title (db/list-todos ds 7)))))
|
||||
(testing "update"
|
||||
(is (= (assoc saved :title "buy oat milk" :done true :updated-at 2000)
|
||||
(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"
|
||||
(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)))
|
||||
(is (false? (db/delete! ds 7 id))))))
|
||||
|
||||
(deftest owner-scoping-test
|
||||
(let [ds (db/open (temp-db-path))
|
||||
mine (db/insert! ds (todo 7 "mine"))
|
||||
theirs (db/insert! ds (todo 8 "theirs"))]
|
||||
(is (= [mine] (db/list-todos ds 7)))
|
||||
(is (= [theirs] (db/list-todos ds 8)))
|
||||
(is (= [] (db/list-todos ds 9)))
|
||||
(testing "another owner's todo can't be found, changed, or deleted by its id"
|
||||
(is (nil? (db/find-todo ds 8 (:id mine))))
|
||||
(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)))))))))
|
||||
@@ -0,0 +1,107 @@
|
||||
(ns tbd.todo.routes-test
|
||||
(:require [clojure.java.io :as io]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[tbd.auth.routes-test :as t]
|
||||
[tbd.test-util :as test-util]
|
||||
[tbd.sqlite-test :as sqlite-test])
|
||||
(:import (java.io ByteArrayInputStream)))
|
||||
|
||||
(defn request
|
||||
"`body` is a JSON string (or nil). The response body is decoded by its Content-Type."
|
||||
[app method uri cookie & [body]]
|
||||
(let [resp (app (cond-> {:request-method method :uri uri :headers (cond-> {} cookie (assoc "cookie" cookie))}
|
||||
body (-> (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))
|
||||
(assoc-in [:headers "content-type"] "application/json"))))]
|
||||
(test-util/decode-body resp)))
|
||||
|
||||
(defn app-for [db-path login id]
|
||||
(t/make-app (t/gitea-stub login id) :db {:db-path db-path}))
|
||||
|
||||
(def ^:private todos "/api/todos")
|
||||
|
||||
(deftest anonymous-test
|
||||
(let [path (sqlite-test/temp-db-path)
|
||||
app (app-for path "alice" 7)]
|
||||
(doseq [[method uri body] [[:get todos nil]
|
||||
[:post todos "{\"title\":\"x\"}"]
|
||||
[:post todos "nope"]
|
||||
[:get (str todos "/1") nil]
|
||||
[:patch (str todos "/1") "{\"done\":true}"]
|
||||
[:delete (str todos "/1") nil]]]
|
||||
(let [resp (request app method uri nil body)]
|
||||
(is (= 401 (:status resp)) (str method " " uri))
|
||||
(is (= {:error "login required"} (:body resp)))))
|
||||
(is (not (.exists (io/file path))) "the database isn't even opened")))
|
||||
|
||||
(deftest lifecycle-test
|
||||
(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)]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= "application/edn; charset=utf-8" (get-in resp [:headers "Content-Type"])))
|
||||
(is (= {:todos []} (:body resp)))))
|
||||
(testing "create"
|
||||
(let [resp (request app :post todos cookie "{\"title\":\" buy milk \"}")
|
||||
{: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 (uuid? (parse-uuid id)))
|
||||
(testing "get"
|
||||
(is (= created (:body (request app :get (str todos "/" id) cookie)))))
|
||||
(testing "patch"
|
||||
(let [resp (request app :patch (str todos "/" id) cookie "{\"done\":true}")]
|
||||
(is (= 200 (:status resp)))
|
||||
(is (= (dissoc (assoc created :done true) :updated-at) (dissoc (:body resp) :updated-at))))
|
||||
(is (= "oat milk" (:title (:body (request app :patch (str todos "/" id) cookie "{\"title\":\"oat milk\"}"))))))
|
||||
(testing "list"
|
||||
(request app :post todos cookie "{\"title\":\"walk dog\"}")
|
||||
(is (= ["oat milk" "walk dog"] (map :title (:todos (:body (request app :get todos cookie)))))))
|
||||
(testing "delete"
|
||||
(is (= {:status 200 :body {:deleted true}}
|
||||
(select-keys (request app :delete (str todos "/" id) cookie) [:status :body])))
|
||||
(is (= 404 (:status (request app :get (str todos "/" id) cookie))))
|
||||
(is (= 404 (:status (request app :delete (str todos "/" id) cookie))))
|
||||
(is (= ["walk dog"] (map :title (:todos (:body (request app :get todos cookie)))))))))))
|
||||
|
||||
(deftest validation-test
|
||||
(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))]
|
||||
(testing "bad titles on create"
|
||||
(doseq [body ["{\"title\":\"\"}" "{\"title\":\" \"}" "{}" "{\"title\":5}" "{\"title\":null}" "nope"
|
||||
(format "{\"title\":\"%s\"}" (apply str (repeat 201 "x")))]]
|
||||
(let [resp (request app :post todos cookie body)]
|
||||
(is (= 400 (:status resp)) body)
|
||||
(is (contains? (:body resp) :error)))))
|
||||
(testing "bad changes"
|
||||
(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 "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 (sqlite-test/temp-db-path)
|
||||
alice-app (app-for path "alice" 7)
|
||||
bob-app (app-for path "bob" 8)
|
||||
alice (t/login! alice-app)
|
||||
bob (t/login! bob-app)
|
||||
{:keys [id] :as mine} (:body (request alice-app :post todos alice "{\"title\":\"alice's\"}"))
|
||||
one (str todos "/" id)]
|
||||
(testing "each user lists only their own"
|
||||
(is (= [] (:todos (:body (request bob-app :get todos bob)))))
|
||||
(request bob-app :post todos bob "{\"title\":\"bob's\"}")
|
||||
(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 "/" (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))
|
||||
(is (= (:body missing) (:body resp)))))))
|
||||
(is (= mine (:body (request alice-app :get one alice))) "alice's todo is untouched")))
|
||||
@@ -0,0 +1,75 @@
|
||||
(ns tbd.todo.service-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[tbd.todo.core :as todo]
|
||||
[tbd.todo.db :as db]
|
||||
[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.
|
||||
;; They are tested here once; the front ends' tests only cover their own translation.
|
||||
|
||||
(def alice {:id 7 :login "alice"})
|
||||
(def bob {:id 8 :login "bob"})
|
||||
|
||||
(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})
|
||||
|
||||
(deftest lifecycle-test
|
||||
(let [ds (fresh-ds)]
|
||||
(is (= {:ok []} (service/list-todos ds alice)))
|
||||
(let [{created :ok} (service/create! ds alice " buy milk ")
|
||||
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 (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"
|
||||
(is (= {:title "buy milk" :done true}
|
||||
(select-keys (:ok (service/update! ds alice id {:done true})) [:title :done])))
|
||||
(is (= {:title "oat milk" :done true}
|
||||
(select-keys (:ok (service/update! ds alice id {:title "oat milk"})) [:title :done])))
|
||||
(is (= "oat milk" (:title (:ok (service/find-todo ds alice id)))) "and it is stored"))
|
||||
(testing "delete"
|
||||
(is (= {:ok true} (service/delete! ds alice id)))
|
||||
(is (= not-found (service/find-todo ds alice id)))
|
||||
(is (= not-found (service/delete! ds alice id)))
|
||||
(is (= {:ok []} (service/list-todos ds alice)))))))
|
||||
|
||||
(deftest validation-test
|
||||
(let [ds (fresh-ds)
|
||||
id (:id (:ok (service/create! ds alice "keep")))]
|
||||
(testing "the rules of tbd.todo.core apply, as :invalid"
|
||||
(is (= {:error "title must not be blank" :kind :invalid} (service/create! ds alice " ")))
|
||||
(is (= {:error (format "title must be at most %d characters" todo/max-title-length) :kind :invalid}
|
||||
(service/create! ds alice (apply str (repeat (inc todo/max-title-length) "x")))))
|
||||
(is (= {:error "title must not be blank" :kind :invalid} (service/update! ds alice id {:title " "})))
|
||||
(is (= {:error "nothing to change: give a title and/or done" :kind :invalid}
|
||||
(service/update! ds alice id {}))))
|
||||
(is (= ["keep"] (map :title (:ok (service/list-todos ds alice)))) "nothing above changed anything")))
|
||||
|
||||
(deftest ownership-test
|
||||
(let [ds (fresh-ds)
|
||||
{mine :ok} (service/create! ds alice "alice's")
|
||||
id (:id mine)]
|
||||
(testing "each user has their own list"
|
||||
(service/create! ds bob "bob's")
|
||||
(is (= ["alice's"] (map :title (:ok (service/list-todos ds alice)))))
|
||||
(is (= ["bob's"] (map :title (:ok (service/list-todos ds bob))))))
|
||||
(testing "someone else's todo is reported exactly like a missing one"
|
||||
(let [missing (service/find-todo ds bob 999999)]
|
||||
(is (= not-found missing))
|
||||
(is (= missing (service/find-todo ds bob id)))
|
||||
(is (= missing (service/update! ds bob id {:title "hijacked"})))
|
||||
(is (= missing (service/delete! ds bob id)))))
|
||||
(is (= {:ok mine} (service/find-todo ds alice id)) "and alice's todo is untouched")))
|
||||
|
||||
(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 (sqlite-test/temp-db-path)))]
|
||||
(is (zero? @opened))
|
||||
(service/list-todos ds alice)
|
||||
(service/list-todos ds alice)
|
||||
(is (= 1 @opened)))))
|
||||
@@ -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"]
|
||||
}
|
||||
Generated
+2702
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,22 @@
|
||||
{
|
||||
"name": "tbd-ui",
|
||||
"private": true,
|
||||
"version": "0.0.0",
|
||||
"description": "ClojureScript (re-frame) front end for the tbd server",
|
||||
"scripts": {
|
||||
"watch": "shadow-cljs watch 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",
|
||||
"react": "^19.3.0",
|
||||
"react-dom": "^19.3.0"
|
||||
},
|
||||
"devDependencies": {
|
||||
"c8": "^12.0.0",
|
||||
"jsdom": "^30.1.0",
|
||||
"shadow-cljs": "^3.5.3"
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,22 @@
|
||||
;; 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`). ../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"]
|
||||
[re-frame "1.4.7"]]
|
||||
|
||||
:builds
|
||||
{:app {:target :browser
|
||||
:output-dir "../resources/public/js"
|
||||
:asset-path "/js"
|
||||
:modules {:main {:init-fn tbd.ui.core/init}}
|
||||
:devtools {:after-load tbd.ui.core/reload}}
|
||||
|
||||
;; 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$"}}}
|
||||
@@ -0,0 +1,34 @@
|
||||
(ns tbd.ui.core
|
||||
(: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]))
|
||||
|
||||
(defonce root (atom nil))
|
||||
|
||||
(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!)
|
||||
(offer-tools!)
|
||||
(render))
|
||||
|
||||
(defn init []
|
||||
(rf/dispatch-sync [::events/initialize])
|
||||
(reset! root (rdc/create-root (js/document.getElementById "app")))
|
||||
(offer-tools!)
|
||||
(render))
|
||||
@@ -0,0 +1,46 @@
|
||||
(ns tbd.ui.db
|
||||
(:require [tbd.ui.tictactoe :as tictactoe]))
|
||||
|
||||
(def default-db
|
||||
{;; 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}}
|
||||
;; :user is {:status :unknown}, {:status :anonymous}, {:status :logged-in :login "alice"}, or
|
||||
;; {:status :error :message}.
|
||||
:user {:status :unknown}
|
||||
:todos {;; :status is :idle, :loading, :ok or :error; :error is the last failed request's
|
||||
;; message, cleared when the next request starts.
|
||||
:status :idle
|
||||
:items []
|
||||
:new-title ""
|
||||
:error nil}
|
||||
;; The "Add this MCP server to Claude Code" page. :copied? is true right after the command was
|
||||
;; copied to the clipboard.
|
||||
:mcp {:copied? false}
|
||||
;; 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}})
|
||||
@@ -0,0 +1,818 @@
|
||||
(ns tbd.ui.events
|
||||
(:require [cljs.reader :as reader]
|
||||
[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]))
|
||||
|
||||
(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-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
|
||||
[(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]]
|
||||
(assoc-in db [:calc k] value)))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::add
|
||||
(fn [{:keys [db]} _]
|
||||
(let [{:keys [x y]} (:calc db)]
|
||||
{:db (assoc-in db [:calc :result] {:status :loading})
|
||||
::fetch {:uri (str "/api/add?x=" (js/encodeURIComponent x)
|
||||
"&y=" (js/encodeURIComponent y))
|
||||
:on-response [::add-response x y]}})))
|
||||
|
||||
(defn- error-message
|
||||
"The API answers bad input with EDN like {:error \"...\" :details {:x [...]}}."
|
||||
[{:keys [status body]}]
|
||||
(let [{:keys [error details]} (try (reader/read-string body) (catch :default _ nil))]
|
||||
(cond
|
||||
error (str error (when (seq details) (str " (" (str/join ", " (map name (keys details))) ")")))
|
||||
status (str "HTTP " status)
|
||||
:else body)))
|
||||
|
||||
(rf/reg-event-db
|
||||
::add-response
|
||||
(fn [db [_ x y {:keys [ok? body] :as resp}]]
|
||||
(assoc-in db [:calc :result]
|
||||
(if ok?
|
||||
{:status :ok :x x :y y :sum (:result (reader/read-string body))}
|
||||
{:status :error :message (error-message resp)}))))
|
||||
|
||||
;; --- Login state ---
|
||||
|
||||
(rf/reg-event-fx
|
||||
::load-user
|
||||
(fn [_ _]
|
||||
{::fetch {:uri "/auth/me" :on-response [::user-response]}}))
|
||||
|
||||
;; 401 just means "not logged in"; anything else is a real failure.
|
||||
(rf/reg-event-fx
|
||||
::user-response
|
||||
(fn [{:keys [db]} [_ {:keys [ok? status] :as resp}]]
|
||||
(cond
|
||||
ok? {:db (assoc db :user {:status :logged-in
|
||||
:login (:login (reader/read-string (:body resp)))})
|
||||
: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)})})))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::logout
|
||||
(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?
|
||||
(-> db
|
||||
(assoc :user {:status :anonymous} :todos (:todos db/default-db))
|
||||
reset-chat)
|
||||
(assoc-in db [:todos :error] (error-message resp)))))
|
||||
|
||||
;; --- Todos ---
|
||||
|
||||
(defn- start-request [db]
|
||||
(assoc-in db [:todos :error] nil))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::load-todos
|
||||
(fn [{:keys [db]} _]
|
||||
{:db (-> db start-request (assoc-in [:todos :status] :loading))
|
||||
::fetch {:uri "/api/todos" :on-response [::todos-response]}}))
|
||||
|
||||
(rf/reg-event-db
|
||||
::todos-response
|
||||
(fn [db [_ {:keys [ok? body] :as resp}]]
|
||||
(if ok?
|
||||
(update db :todos assoc :status :ok :items (:todos (reader/read-string body)))
|
||||
(update db :todos assoc :status :error :error (error-message resp)))))
|
||||
|
||||
;; 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}]]
|
||||
(if (= 401 status)
|
||||
(assoc db :user {:status :anonymous} :todos (:todos db/default-db))
|
||||
(assoc-in db [:todos :error] (error-message resp)))))
|
||||
|
||||
(rf/reg-event-db
|
||||
::set-new-title
|
||||
(fn [db [_ title]]
|
||||
(assoc-in db [:todos :new-title] title)))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::add-todo
|
||||
(fn [{:keys [db]} _]
|
||||
{:db (start-request db)
|
||||
::fetch {:uri "/api/todos" :method "POST"
|
||||
:body {:title (get-in db [:todos :new-title])}
|
||||
:on-response [::todo-added]}}))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::todo-added
|
||||
(fn [{:keys [db]} [_ {:keys [ok? body] :as resp}]]
|
||||
(if ok?
|
||||
{:db (update db :todos (fn [todos]
|
||||
(-> todos
|
||||
(update :items conj (reader/read-string body))
|
||||
(assoc :new-title ""))))}
|
||||
{:dispatch [::todo-failed resp]})))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::set-done
|
||||
(fn [{:keys [db]} [_ id done?]]
|
||||
{:db (start-request db)
|
||||
::fetch {:uri (str "/api/todos/" id) :method "PATCH"
|
||||
:body {:done done?}
|
||||
:on-response [::todo-changed]}}))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::todo-changed
|
||||
(fn [{:keys [db]} [_ {:keys [ok? body] :as resp}]]
|
||||
(if ok?
|
||||
(let [changed (reader/read-string body)]
|
||||
{:db (update-in db [:todos :items]
|
||||
(fn [items] (mapv #(if (= (:id %) (:id changed)) changed %) items)))})
|
||||
{:dispatch [::todo-failed resp]})))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::delete-todo
|
||||
(fn [{:keys [db]} [_ id]]
|
||||
{:db (start-request db)
|
||||
::fetch {:uri (str "/api/todos/" id) :method "DELETE"
|
||||
:on-response [::todo-deleted id]}}))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::todo-deleted
|
||||
(fn [{:keys [db]} [_ id {:keys [ok?] :as resp}]]
|
||||
(if ok?
|
||||
{:db (update-in db [:todos :items] (fn [items] (filterv #(not= id (:id %)) items)))}
|
||||
{:dispatch [::todo-failed resp]})))
|
||||
|
||||
;; --- Chat ---
|
||||
|
||||
;; 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]
|
||||
(some-> js/navigator.clipboard (.writeText text) (.catch (fn [_] nil)))))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::copy-mcp-command
|
||||
(fn [{:keys [db]} [_ command]]
|
||||
{:db (assoc-in db [:mcp :copied?] true)
|
||||
::copy-to-clipboard command
|
||||
:dispatch-later [{:ms 2000 :dispatch [::mcp-copied-timeout]}]}))
|
||||
|
||||
(rf/reg-event-db
|
||||
::mcp-copied-timeout
|
||||
(fn [db _]
|
||||
(assoc-in db [:mcp :copied?] false)))
|
||||
|
||||
;; --- Tic-tac-toe ---
|
||||
|
||||
(rf/reg-event-fx
|
||||
::ttt-move
|
||||
(fn [{:keys [db]} [_ i]]
|
||||
(let [{:keys [board turn]} (:ttt db)]
|
||||
(if-let [board' (tictactoe/move board turn i)]
|
||||
(let [ttt {:board board' :turn (tictactoe/next-player turn)}]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})
|
||||
{:db db}))))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::ttt-reset
|
||||
(fn [{:keys [db]} _]
|
||||
(let [ttt (:ttt db/default-db)]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})))
|
||||
@@ -0,0 +1,189 @@
|
||||
(ns tbd.ui.markdown
|
||||
"Turns a chat message's Markdown into Reagent hiccup, for `chat-bubble` to show as blocks
|
||||
(headings, lists, code, blockquotes, tables) and inline formatting (bold, italic, code, links)
|
||||
instead of flat text. Hand-rolled rather than an npm library: not full CommonMark (no nested
|
||||
lists, and a table or list has to start right after a blank line, not mid-paragraph), but
|
||||
covers what a chat message actually uses.
|
||||
|
||||
No HTML is ever built as a string and injected (no :dangerouslySetInnerHTML, so nothing to run
|
||||
a sanitizer library over either): every leaf here is a plain Clojure string, which Reagent
|
||||
turns into a text node the same way any other hiccup content is, so it can never be read back
|
||||
as markup. The one place a message's text becomes an attribute rather than a text node is a
|
||||
link's `href`, which `safe-href` checks by hand."
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
;; --- Block matchers (tested against a left-trimmed line) ---
|
||||
|
||||
(def ^:private fence-re #"^```\s*(\S*)\s*$")
|
||||
(def ^:private fence-close-re #"^\s*```\s*$")
|
||||
(def ^:private heading-re #"^(#{1,6})\s+(.*)$")
|
||||
(def ^:private hr-re #"^(?:-{3,}|\*{3,}|_{3,})\s*$")
|
||||
(def ^:private quote-re #"^>\s?(.*)$")
|
||||
(def ^:private ul-re #"^[-*+]\s+(.*)$")
|
||||
(def ^:private ol-re #"^\d+[.)]\s+(.*)$")
|
||||
(def ^:private table-sep-re #"^\|?\s*:?-+:?\s*(\|\s*:?-+:?\s*)*\|?\s*$")
|
||||
|
||||
(defn- block-starter?
|
||||
"Whether `line` begins a block of its own, so a paragraph reading lines one at a time stops
|
||||
before it even without a blank line in between."
|
||||
[line]
|
||||
(let [l (str/triml line)]
|
||||
(boolean (or (str/blank? l) (re-find fence-re l) (re-find heading-re l) (re-find hr-re l)
|
||||
(re-find quote-re l) (re-find ul-re l) (re-find ol-re l)))))
|
||||
|
||||
;; --- Inline formatting ---
|
||||
|
||||
(def ^:private allowed-schemes #{"http" "https" "mailto" "tel"})
|
||||
|
||||
(defn- safe-href
|
||||
"`url` if it's fine to put in an href (no scheme, i.e. relative, or one of `allowed-schemes`),
|
||||
else nil: the model can write a `javascript:` link too, whether it means to or not (quoting one
|
||||
from a tool result), and React itself won't stop that from running on a click."
|
||||
[url]
|
||||
(let [scheme (second (re-find #"^([A-Za-z][A-Za-z0-9+.-]*):" url))]
|
||||
(when (or (nil? scheme) (contains? allowed-schemes (str/lower-case scheme)))
|
||||
url)))
|
||||
|
||||
(defn- flanked?
|
||||
"Whether `s` is a fit inside for an emphasis/strong span: not empty, and not padded with a
|
||||
space, which is usually a stray `*` or `_` doing something else (\"3 * 4 * 5\") rather than
|
||||
marking emphasis."
|
||||
[s]
|
||||
(and (seq s) (not (str/starts-with? s " ")) (not (str/ends-with? s " "))))
|
||||
|
||||
(def ^:private link-re #"^\[([^\]]*)\]\(([^)\s]+)(?:\s+\"[^\"]*\")?\)")
|
||||
|
||||
(defn- flush-text
|
||||
"`out` with the literal text `s[from, to)` appended, if there is any."
|
||||
[out s from to]
|
||||
(if (< from to) (conj out (subs s from to)) out))
|
||||
|
||||
(defn- inline-line->hiccup
|
||||
"One line's worth of inline Markdown (no newlines: see `inline->hiccup` for those) as a vector
|
||||
of hiccup children: plain strings and `:code`/`:strong`/`:em`/`:a` elements."
|
||||
[s]
|
||||
(let [n (count s)]
|
||||
(loop [i 0, flush 0, out []]
|
||||
(if (>= i n)
|
||||
(flush-text out s flush n)
|
||||
(let [c (subs s i (inc i))
|
||||
two (when (<= (+ i 2) n) (subs s i (+ i 2)))]
|
||||
(cond
|
||||
(= c "`")
|
||||
(if-let [j (str/index-of s "`" (inc i))]
|
||||
(recur (inc j) (inc j) (conj (flush-text out s flush i) [:code (subs s (inc i) j)]))
|
||||
(recur (inc i) flush out))
|
||||
|
||||
(contains? #{"**" "__"} two)
|
||||
(let [j (str/index-of s two (+ i 2))
|
||||
inner (when j (subs s (+ i 2) j))]
|
||||
(if (flanked? inner)
|
||||
(recur (+ j 2) (+ j 2)
|
||||
(conj (flush-text out s flush i) (into [:strong] (inline-line->hiccup inner))))
|
||||
(recur (inc i) flush out)))
|
||||
|
||||
(contains? #{"*" "_"} c)
|
||||
(let [j (str/index-of s c (inc i))
|
||||
inner (when j (subs s (inc i) j))]
|
||||
(if (flanked? inner)
|
||||
(recur (inc j) (inc j)
|
||||
(conj (flush-text out s flush i) (into [:em] (inline-line->hiccup inner))))
|
||||
(recur (inc i) flush out)))
|
||||
|
||||
(= c "[")
|
||||
(if-let [[whole label url] (re-find link-re (subs s i))]
|
||||
(let [href (safe-href url)
|
||||
label-pieces (inline-line->hiccup label)
|
||||
node (if href
|
||||
(into [:a {:href href :target "_blank" :rel "noopener noreferrer"}] label-pieces)
|
||||
(into [:span] label-pieces))]
|
||||
(recur (+ i (count whole)) (+ i (count whole)) (conj (flush-text out s flush i) node)))
|
||||
(recur (inc i) flush out))
|
||||
|
||||
:else (recur (inc i) flush out)))))))
|
||||
|
||||
(defn- inline->hiccup
|
||||
"`text` (possibly several lines: a paragraph's or a blockquote line's own soft-wrapped lines)
|
||||
as hiccup children, a `:br` between each line, the way a bare newline reads in a chat message
|
||||
someone typed without Markdown's blank-line-between-paragraphs convention in mind."
|
||||
[text]
|
||||
(vec (apply concat (interpose [[:br]] (map inline-line->hiccup (str/split text #"\n"))))))
|
||||
|
||||
;; --- Blocks ---
|
||||
|
||||
(defn- code-block [lang lines]
|
||||
[:pre [:code (if (seq lang) {:class (str "language-" lang)} {}) (str/join "\n" lines)]])
|
||||
|
||||
(defn- table-cells [line]
|
||||
(->> (-> (str/trim line)
|
||||
(str/replace #"^\|" "")
|
||||
(str/replace #"\|$" "")
|
||||
(str/split #"\|"))
|
||||
(mapv str/trim)))
|
||||
|
||||
(defn- table [header-line body-lines]
|
||||
(let [header (table-cells header-line)
|
||||
rows (mapv table-cells body-lines)]
|
||||
[:table
|
||||
[:thead (into [:tr] (map #(into [:th] (inline-line->hiccup %)) header))]
|
||||
(into [:tbody] (map (fn [row] (into [:tr] (map #(into [:td] (inline-line->hiccup %)) row))) rows))]))
|
||||
|
||||
(declare parse-blocks)
|
||||
|
||||
(defn- parse-blocks
|
||||
"`text`'s block-level structure, as a vector of hiccup elements."
|
||||
[text]
|
||||
(loop [lines (vec (str/split text #"\n")), out []]
|
||||
(if (empty? lines)
|
||||
out
|
||||
(let [line (first lines)
|
||||
trimmed (str/triml line)]
|
||||
(cond
|
||||
(str/blank? trimmed) (recur (subvec lines 1) out)
|
||||
|
||||
(re-find fence-re trimmed)
|
||||
(let [lang (second (re-find fence-re trimmed))
|
||||
rest-lines (subvec lines 1)
|
||||
close (first (keep-indexed #(when (re-find fence-close-re %2) %1) rest-lines))
|
||||
end (or close (count rest-lines))]
|
||||
(recur (subvec rest-lines (min (count rest-lines) (inc end)))
|
||||
(conj out (code-block lang (subvec rest-lines 0 end)))))
|
||||
|
||||
(re-find heading-re trimmed)
|
||||
(let [[_ hashes content] (re-find heading-re trimmed)]
|
||||
(recur (subvec lines 1)
|
||||
(conj out (into [(keyword (str "h" (count hashes)))] (inline-line->hiccup content)))))
|
||||
|
||||
(re-find hr-re trimmed) (recur (subvec lines 1) (conj out [:hr]))
|
||||
|
||||
(re-find quote-re trimmed)
|
||||
(let [quoted (take-while #(re-find quote-re (str/triml %)) lines)
|
||||
inner (str/join "\n" (map #(second (re-find quote-re (str/triml %))) quoted))]
|
||||
(recur (subvec lines (count quoted)) (conj out (into [:blockquote] (parse-blocks inner)))))
|
||||
|
||||
(re-find ul-re trimmed)
|
||||
(let [items (take-while #(re-find ul-re (str/triml %)) lines)]
|
||||
(recur (subvec lines (count items))
|
||||
(conj out (into [:ul] (map #(into [:li] (inline-line->hiccup (second (re-find ul-re (str/triml %)))))
|
||||
items)))))
|
||||
|
||||
(re-find ol-re trimmed)
|
||||
(let [items (take-while #(re-find ol-re (str/triml %)) lines)]
|
||||
(recur (subvec lines (count items))
|
||||
(conj out (into [:ol] (map #(into [:li] (inline-line->hiccup (second (re-find ol-re (str/triml %)))))
|
||||
items)))))
|
||||
|
||||
(and (str/includes? trimmed "|") (> (count lines) 1)
|
||||
(re-find table-sep-re (str/triml (second lines))))
|
||||
(let [body (->> (subvec lines 2) (take-while #(str/includes? (str/triml %) "|")))]
|
||||
(recur (subvec lines (+ 2 (count body))) (conj out (table trimmed body))))
|
||||
|
||||
:else
|
||||
(let [para (take-while (complement block-starter?) lines)]
|
||||
(recur (subvec lines (count para))
|
||||
(conj out (into [:p] (inline->hiccup (str/join "\n" (map str/trim para))))))))))))
|
||||
|
||||
(defn render
|
||||
"`text` (Markdown, possibly blank) as a Reagent fragment, ready to use as a hiccup child."
|
||||
[text]
|
||||
(into [:<>] (parse-blocks (str/trim (or text "")))))
|
||||
@@ -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))))
|
||||
@@ -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)))
|
||||
@@ -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)]))
|
||||
@@ -0,0 +1,23 @@
|
||||
(ns tbd.ui.subs
|
||||
(: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)))
|
||||
|
||||
;; What the board view needs: the cells, whose turn, and how the game stands.
|
||||
;; :outcome is nil while the game is on, or {:player :x-or-:o :line [..]} for a win, or :draw.
|
||||
(rf/reg-sub
|
||||
::ttt-game
|
||||
:<- [::ttt]
|
||||
(fn [{:keys [board turn]} _]
|
||||
{:board board
|
||||
:turn turn
|
||||
:outcome (tictactoe/outcome board)}))
|
||||
@@ -0,0 +1,39 @@
|
||||
(ns tbd.ui.tictactoe
|
||||
"Tic-tac-toe rules as plain functions of the board, called by the re-frame events and subs
|
||||
(tbd.ui.events, tbd.ui.subs). The board is a vector of 9 cells, row by row, each nil, :x or :o.")
|
||||
|
||||
(def new-board (vec (repeat 9 nil)))
|
||||
|
||||
(def ^:private lines
|
||||
[[0 1 2] [3 4 5] [6 7 8]
|
||||
[0 3 6] [1 4 7] [2 5 8]
|
||||
[0 4 8] [2 4 6]])
|
||||
|
||||
(defn winner
|
||||
"{:player :x-or-:o :line [i j k]} when someone has three in a row, else nil."
|
||||
[board]
|
||||
(some (fn [[a b c :as line]]
|
||||
(let [player (board a)]
|
||||
(when (and player (= player (board b) (board c)))
|
||||
{:player player :line line})))
|
||||
lines))
|
||||
|
||||
(defn draw?
|
||||
"The board is full and nobody won."
|
||||
[board]
|
||||
(and (every? some? board) (nil? (winner board))))
|
||||
|
||||
(defn outcome
|
||||
"How the game stands: nil while it's on, :draw, or the winner (see `winner`)."
|
||||
[board]
|
||||
(or (winner board) (when (draw? board) :draw)))
|
||||
|
||||
(defn next-player [player]
|
||||
(if (= :x player) :o :x))
|
||||
|
||||
(defn move
|
||||
"`player` takes cell `i`. Returns the new board, or nil when the move isn't allowed (the cell
|
||||
is taken or off the board, or the game is already over)."
|
||||
[board player i]
|
||||
(when (and (contains? board i) (nil? (board i)) (nil? (winner board)))
|
||||
(assoc board i player)))
|
||||
@@ -0,0 +1,494 @@
|
||||
(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]))
|
||||
|
||||
(defn- operand-input [k label]
|
||||
[:label label " "
|
||||
[:input {:type "number" :step "any" :required true :name (name k)
|
||||
:style {:width "6rem"}
|
||||
:value @(rf/subscribe [::subs/operand k])
|
||||
:on-change #(rf/dispatch [::events/set-operand k (.. % -target -value)])}]])
|
||||
|
||||
(defn- result-line [{:keys [status x y sum message]}]
|
||||
(case status
|
||||
:idle nil
|
||||
:loading [:p "Adding…"]
|
||||
:ok [:p {:aria-live "polite"} x " + " y " = " [:strong sum]]
|
||||
:error [:p {:role "alert" :style {:color "crimson"}} message]))
|
||||
|
||||
(defn calculator
|
||||
"Sends GET /api/add?x=..&y=.. on submit and shows the sum the server returns."
|
||||
[]
|
||||
(let [result @(rf/subscribe [::subs/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"}}
|
||||
[:label {:style {:flex 1 :text-decoration (when done "line-through") :opacity (when done 0.6)}}
|
||||
[:input {:type "checkbox" :checked (boolean done)
|
||||
:on-change #(rf/dispatch [::events/set-done id (.. % -target -checked)])}]
|
||||
" " title]
|
||||
[:button {:type "button" :aria-label (str "Delete " title)
|
||||
:on-click #(rf/dispatch [::events/delete-todo id])}
|
||||
"Delete"]])
|
||||
|
||||
(defn- todo-list [{:keys [status items]}]
|
||||
(cond
|
||||
(and (= :loading status) (empty? items)) [:p "Loading…"]
|
||||
(and (= :ok status) (empty? items)) [:p "Nothing to do."]
|
||||
:else [:ul {:style {:list-style "none" :padding 0}}
|
||||
(for [todo items]
|
||||
^{:key (:id todo)} [todo-item todo])]))
|
||||
|
||||
(defn todos
|
||||
"Your todos (GET/POST /api/todos, PATCH/DELETE /api/todos/:id)."
|
||||
[]
|
||||
(let [{:keys [new-title error] :as state} @(rf/subscribe [::subs/todos])]
|
||||
[:section
|
||||
[:h2 "Todos"]
|
||||
[:form {:on-submit (fn [e]
|
||||
(.preventDefault e)
|
||||
(rf/dispatch [::events/add-todo]))}
|
||||
[:input {:type "text" :name "title" :required true :placeholder "What needs doing?"
|
||||
:aria-label "New todo"
|
||||
:style {:width "20rem"}
|
||||
:value new-title
|
||||
:on-change #(rf/dispatch [::events/set-new-title (.. % -target -value)])}]
|
||||
" "
|
||||
[:button {:type "submit"} "Add"]]
|
||||
(when error [:p {:role "alert" :style {:color "crimson"}} error])
|
||||
[todo-list state]]))
|
||||
|
||||
(defn- ttt-status [{:keys [turn outcome]}]
|
||||
(cond
|
||||
(= :draw outcome) "It's a draw."
|
||||
outcome (str (str/upper-case (name (:player outcome))) " wins!")
|
||||
:else (str (str/upper-case (name turn)) "'s turn")))
|
||||
|
||||
(defn- ttt-cell [i mark winning? over?]
|
||||
[:button {:type "button"
|
||||
:aria-label (str "Cell " (inc i) (when mark (str ", " (str/upper-case (name mark)))))
|
||||
:disabled (or over? (some? mark))
|
||||
:style {:aspect-ratio "1" :font-size "2.5rem" :font-weight "bold" :cursor "pointer"
|
||||
:background (when winning? "gold") :color (when winning? "black")}
|
||||
:on-click #(rf/dispatch [::events/ttt-move i])}
|
||||
(some-> mark name str/upper-case)])
|
||||
|
||||
(defn tic-tac-toe
|
||||
"Two players take turns on one board. Nothing goes to the server."
|
||||
[]
|
||||
(let [{:keys [board outcome] :as game} @(rf/subscribe [::subs/ttt-game])
|
||||
winning (set (:line outcome))]
|
||||
[:section
|
||||
[:h2 "Tic-tac-toe"]
|
||||
[:p {:role "status" :aria-live "polite"} (ttt-status game)]
|
||||
[:div {:style {:display "grid" :grid-template-columns "repeat(3, 4.5rem)" :gap "0.25rem"
|
||||
:width "fit-content"}}
|
||||
(for [[i mark] (map-indexed vector board)]
|
||||
^{:key i} [ttt-cell i mark (contains? winning i) (some? outcome)])]
|
||||
[:p [:button {:type "button" :on-click #(rf/dispatch [::events/ttt-reset])} "New game"]]]))
|
||||
|
||||
(defn- mcp-command
|
||||
"The command that adds this server to Claude Code, for the address the page was loaded from
|
||||
(which is what BASE_URL has to be for the MCP login to work)."
|
||||
[]
|
||||
(str "claude mcp add --transport http tbd " js/location.origin "/mcp"))
|
||||
|
||||
(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?])]
|
||||
[: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"
|
||||
:border "1px solid GrayText" :border-radius "0.25rem"}}
|
||||
[:code command]]
|
||||
(when js/navigator.clipboard
|
||||
[:button {:type "button" :aria-live "polite"
|
||||
:on-click #(rf/dispatch [::events/copy-mcp-command command])}
|
||||
(if copied? "Copied" "Copy")])]
|
||||
[:p "Then sign in, once:"]
|
||||
[:ol
|
||||
[:li "Start " [:code "claude"] " and type " [:code "/mcp"] "."]
|
||||
[:li "Choose " [:code "tbd"] ", then " [:strong "Authenticate"]
|
||||
". Your browser opens: log in with Gitea if asked, and click " [:strong "Approve"] "."]
|
||||
[:li "Back in Claude Code, try: " [:em "\"use the tbd whoami tool\""] "."]]]))
|
||||
|
||||
(defn browser-tools
|
||||
"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."
|
||||
[]
|
||||
[: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:"]
|
||||
[:ol
|
||||
[:li "Add the WebMCP server to your MCP client, once: " [:code "npx -y @jason.today/webmcp@latest --config claude"]
|
||||
" (restart Claude Desktop afterwards)."]
|
||||
[:li "Ask your MCP client: " [:em "\"make a webmcp token\""] "."]
|
||||
[:li "Click the blue square in the bottom right corner of this page, paste the token, and press Connect. "
|
||||
"(The token works once; to disconnect, press Disconnect there.)"]
|
||||
[:li "The tools show up in your client, prefixed with this page's host."]]])
|
||||
|
||||
(defn- link-button [props label]
|
||||
[:button (merge {:type "button"
|
||||
:style {:background "none" :border 0 :padding 0 :font "inherit"
|
||||
:color "LinkText" :text-decoration "underline" :cursor "pointer"}}
|
||||
props)
|
||||
label])
|
||||
|
||||
(defn- auth-link
|
||||
"Log in (a plain navigation to the OAuth flow) or log out (a POST), or nothing until we know."
|
||||
[{:keys [status login]}]
|
||||
(case status
|
||||
:anonymous [:a {:href "/auth/login"} "Log in"]
|
||||
:logged-in [link-button {:title (str "Signed in as " login)
|
||||
:on-click #(rf/dispatch [::events/logout])}
|
||||
"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 [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]]))
|
||||
@@ -0,0 +1,537 @@
|
||||
(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, 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.
|
||||
|
||||
`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 ---
|
||||
|
||||
(def ^:private timeout-ms
|
||||
"How long a tool waits for the server to answer before giving up."
|
||||
10000)
|
||||
|
||||
(defn- db [] @rf-db/app-db)
|
||||
|
||||
(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
|
||||
dispatched, so a tool that changes something waits for the change to show up in the db."
|
||||
[pred what]
|
||||
(js/Promise.
|
||||
(fn [resolve reject]
|
||||
(if (pred (db))
|
||||
(resolve (db))
|
||||
(let [k (keyword "tbd.ui.webmcp" (str (gensym "await")))
|
||||
timer (atom nil)
|
||||
finish! (fn [f v]
|
||||
(remove-watch rf-db/app-db k)
|
||||
(js/clearTimeout @timer)
|
||||
(f v))]
|
||||
(reset! timer (js/setTimeout #(finish! reject (js/Error. (str "timed out waiting for " what)))
|
||||
timeout-ms))
|
||||
(add-watch rf-db/app-db k (fn [_ _ _ new-db]
|
||||
(when (pred new-db) (finish! resolve new-db)))))))))
|
||||
|
||||
(defn- known-user
|
||||
"A promise of the login state, once the page has found out what it is."
|
||||
[]
|
||||
(-> (settled #(not= :unknown (get-in % [:user :status])) "the login state")
|
||||
(.then #(:user %))))
|
||||
|
||||
(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! (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)]
|
||||
(if (= :error status) (fail! error) items))))))
|
||||
|
||||
(defn- todo-failure
|
||||
"Why the last change to the todos failed, or nil. A 401 drops the login, so that counts too."
|
||||
[d]
|
||||
(or (get-in d [:todos :error])
|
||||
(when (not= :logged-in (get-in d [:user :status]))
|
||||
"the login has expired: log in again on the page")))
|
||||
|
||||
(defn- change-todos
|
||||
"Dispatches `event`, then waits for `(done? db)` (or for the change to fail, which throws why),
|
||||
and returns the db."
|
||||
[event done? what]
|
||||
(rf/dispatch-sync event)
|
||||
(-> (settled #(or (todo-failure %) (done? %)) what)
|
||||
(.then (fn [d] (if-let [why (todo-failure d)] (fail! why) d)))))
|
||||
|
||||
(defn- find-todo [items id]
|
||||
(first (filter #(= id (:id %)) items)))
|
||||
|
||||
(defn- find-todo! [items id]
|
||||
(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 (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]}]
|
||||
(case status
|
||||
:logged-in (str "logged in as " login)
|
||||
:anonymous "not logged in"
|
||||
:error (str "could not tell who is logged in: " message))))))
|
||||
|
||||
(defn- get-calculator
|
||||
[_]
|
||||
(:calc (db)))
|
||||
|
||||
(defn- add
|
||||
"Types the numbers into the calculator form and presses Add."
|
||||
[{:keys [x y]}]
|
||||
(when-not (and (number? x) (js/Number.isFinite x) (number? y) (js/Number.isFinite y))
|
||||
(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])
|
||||
(-> (settled #(not= :loading (get-in % [:calc :result :status])) "the sum")
|
||||
(.then (fn [d]
|
||||
(let [{:keys [status sum message]} (get-in d [:calc :result])]
|
||||
(if (= :ok status)
|
||||
{:x x :y y :sum sum}
|
||||
(fail! message)))))))
|
||||
|
||||
(defn- list-todos [_]
|
||||
(logged-in-todos))
|
||||
|
||||
(defn- get-todo
|
||||
"Reads todos by id, all of them or none."
|
||||
[{:keys [todos]}]
|
||||
(check-todos! todos #(check-id! (:id %)))
|
||||
(-> (logged-in-todos)
|
||||
(.then (fn [items] (mapv #(find-todo! items (:id %)) todos)))))
|
||||
|
||||
(defn- create-one
|
||||
"Types the title into the new-todo field and presses Add. A promise of the todo that was created."
|
||||
[{:keys [title]}]
|
||||
(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- 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]}]
|
||||
(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]
|
||||
(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 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
|
||||
empty, else \"x\" or \"o\"), `turn` (whose move it is, while the game is on), and `status`
|
||||
(in_progress, won or draw; with `winner` and `line` when won)."
|
||||
[]
|
||||
(let [{:keys [board turn]} (:ttt (db))
|
||||
{:keys [player line] :as outcome} (tictactoe/outcome board)]
|
||||
(cond-> {:board board}
|
||||
(nil? outcome) (assoc :status "in_progress" :turn turn)
|
||||
(= :draw outcome) (assoc :status "draw")
|
||||
player (assoc :status "won" :winner player :line line))))
|
||||
|
||||
(defn- get-tic-tac-toe [_]
|
||||
(tic-tac-toe-state))
|
||||
|
||||
;; --- State (tbd.ui.model-context/current-state, attached to every request of the page's own
|
||||
;; chatbot instead of spent as a read tool's call; see tbd.ui.model-context's docstring) ---
|
||||
|
||||
(defn- todos-state
|
||||
"The todos, once they have loaded: nil (nothing to add to the state) while they haven't, or
|
||||
there is no login, rather than an empty list that would read as \"there are none\"."
|
||||
[]
|
||||
(let [{:keys [status items]} (:todos (db))]
|
||||
(when (= :ok status)
|
||||
{:todos (mapv #(select-keys % [:id :title :done]) items)})))
|
||||
|
||||
(def state-providers
|
||||
"{:pages :provide}, one per page that has state worth telling the model up front. `provide`
|
||||
returns the page's state as a map, or nil for nothing to add right now (see
|
||||
tbd.ui.model-context/current-state, which merges them)."
|
||||
[{:pages #{:todos} :provide todos-state}
|
||||
{:pages #{:tic-tac-toe} :provide tic-tac-toe-state}
|
||||
{:pages #{:calculator} :provide (fn [] (:calc (db)))}])
|
||||
|
||||
(defn- move-tic-tac-toe
|
||||
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn. 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? #{"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: 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- object-schema [properties required]
|
||||
{:type "object" :properties properties :required required})
|
||||
|
||||
(def ^:private todo-id {:type "string" :description "The todo's id, a UUID as list_todos gives it"})
|
||||
|
||||
(defn- todos-schema
|
||||
"The `todos` argument of the todo tools: a list of objects, one per todo the call is about, so
|
||||
that a batch is one call."
|
||||
[description properties required]
|
||||
(object-schema {:todos {:type "array" :minItems 1 :description description
|
||||
:items (object-schema properties required)}}
|
||||
["todos"]))
|
||||
|
||||
(def tools
|
||||
"The tools, as {:name :description :input-schema :handler :pages}. `pages` is where the page's
|
||||
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 "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" :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" :pages #{:todos} :read-only? true
|
||||
:description (str "Lists the todos this page shows (JSON: id, title, done, created-at, updated-at), oldest first. "
|
||||
"Needs a login on the page")
|
||||
:input-schema (object-schema {} []) :handler list-todos}
|
||||
|
||||
{:name "get_todo" :pages #{:todos} :read-only? true
|
||||
:description (str "Gets todos this page shows, by id (JSON list). Takes a list: to read several, make ONE call "
|
||||
"with all of them")
|
||||
:input-schema (todos-schema "The todos to get, one per todo" {:id todo-id} ["id"])
|
||||
:handler get-todo}
|
||||
|
||||
{:name "create_todo" :pages #{:todos}
|
||||
:description (str "Adds todos: types each title into the new-todo field and presses Add. Takes a list: to add "
|
||||
"several, make ONE call with all of them, never one call per todo")
|
||||
:input-schema (todos-schema "The todos to add, one per todo"
|
||||
{:title {:type "string" :minLength 1 :maxLength 200 :description "What needs doing"}}
|
||||
["title"])
|
||||
:handler create-todo}
|
||||
|
||||
{:name "set_todo_done" :pages #{:todos}
|
||||
:description (str "Ticks or unticks the checkboxes of todos. Takes a list: to change several, make ONE call "
|
||||
"with all of them, never one call per todo")
|
||||
:input-schema (todos-schema "The changes to make, one per todo"
|
||||
{:id todo-id
|
||||
:done {:type "boolean" :description "true to tick it off, false to untick it"}}
|
||||
["id" "done"])
|
||||
:handler set-todo-done}
|
||||
|
||||
{:name "delete_todo" :pages #{:todos}
|
||||
:description (str "Deletes todos for good, by pressing their Delete buttons. Find the id first — from the "
|
||||
"page's current state if you have it, or list_todos — never guess one, and never delete a "
|
||||
"todo the user did not clearly point at. Takes a list: to delete several, make ONE call "
|
||||
"with all of them")
|
||||
:input-schema (todos-schema "The todos to delete, one per todo" {:id todo-id} ["id"])
|
||||
:handler delete-todo}
|
||||
|
||||
{:name "get_tic_tac_toe" :pages #{:tic-tac-toe} :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)")
|
||||
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
|
||||
|
||||
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe} :once-per-turn? true
|
||||
:description (str "Presses a cell of the tic-tac-toe board as `player`, 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 "Which side this move is for"}}
|
||||
["cell" "player"])
|
||||
:handler move-tic-tac-toe}])
|
||||
|
||||
;; --- 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 ---
|
||||
|
||||
(defn- text-result [text error?]
|
||||
;; Property names are strings: WebMCP's are not in the Closure externs, so an advanced build
|
||||
;; would rename plain `.-isError` style access.
|
||||
(let [content #js [#js {"type" "text" "text" text}]]
|
||||
(if error?
|
||||
#js {"content" content "isError" true}
|
||||
#js {"content" content})))
|
||||
|
||||
(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]
|
||||
(-> (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,
|
||||
execute)`. Registering a name again replaces the tool, so this is safe to call again (hot
|
||||
reload). (WebMCP's methods are called by string: they are not in the Closure externs.)"
|
||||
[mcp]
|
||||
(doseq [{:keys [name description input-schema handler]} tools]
|
||||
(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`, `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."
|
||||
[]
|
||||
(-> (or @widget (reset! widget (WebMCP.)))
|
||||
register-tools!
|
||||
register-prompts!
|
||||
register-resources!))
|
||||
@@ -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;
|
||||
}
|
||||
});
|
||||
@@ -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
@@ -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))))
|
||||
@@ -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)")))))
|
||||
@@ -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))))
|
||||
@@ -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)))))
|
||||
@@ -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")))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user