This commit is contained in:
@@ -2,6 +2,7 @@
|
||||
(:require [re-frame.core :as rf]
|
||||
[reagent.dom.client :as rdc]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.model-context :as model-context]
|
||||
[tbd.ui.views :as views]
|
||||
[tbd.ui.webmcp :as webmcp]))
|
||||
|
||||
@@ -10,15 +11,21 @@
|
||||
(defn- render []
|
||||
(rdc/render @root [views/app]))
|
||||
|
||||
(defn- offer-tools!
|
||||
"The page's tools go to the chatbot in the page, and to an agent outside it, through WebMCP."
|
||||
[]
|
||||
(model-context/register! webmcp/tools)
|
||||
(webmcp/register!))
|
||||
|
||||
(defn reload
|
||||
"Called by shadow-cljs after each hot reload."
|
||||
[]
|
||||
(rf/clear-subscription-cache!)
|
||||
(webmcp/register!)
|
||||
(offer-tools!)
|
||||
(render))
|
||||
|
||||
(defn init []
|
||||
(rf/dispatch-sync [::events/initialize])
|
||||
(reset! root (rdc/create-root (js/document.getElementById "app")))
|
||||
(webmcp/register!)
|
||||
(offer-tools!)
|
||||
(render))
|
||||
|
||||
@@ -24,6 +24,27 @@
|
||||
;; The "Add this MCP server to Claude Code" page: :copied? is true right after the
|
||||
;; command was copied to the clipboard.
|
||||
:mcp {:copied? false}
|
||||
;; The chat widget (the green square in the corner): :open? is whether its panel is showing,
|
||||
;; :messages the conversation so far, :input what is typed, :status :idle or :loading (waiting
|
||||
;; for the reply, or for the tools it asked for), and :error the message of the last failed send.
|
||||
;; A message is one of
|
||||
;; {:role "user" :content "..."}
|
||||
;; {:role "assistant" :content "..."}, with :tool-calls [{:id :name :arguments "{...}"}] when
|
||||
;; the LLM asked for tools of the page to be called (:content may then be empty)
|
||||
;; {:role "tool" :tool-call-id "..." :name "..." :content "..." :error? bool}: the result of
|
||||
;; one such call.
|
||||
;; :size is what the panel was dragged to, in px: its :width and the :height of the conversation
|
||||
;; in it (the rest of the panel is the same at any size).
|
||||
;; The other two are for a reply that is still coming or being answered: :pending-calls are the
|
||||
;; calls it has asked for so far, :tool-calls-used how many calls this turn has made.
|
||||
:chat {:open? false
|
||||
:size {:width 320 :height 256}
|
||||
:input ""
|
||||
:messages []
|
||||
:status :idle
|
||||
:error nil
|
||||
:pending-calls nil
|
||||
:tool-calls-used 0}
|
||||
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is.
|
||||
:ttt {:board tictactoe/new-board
|
||||
:turn :x}})
|
||||
|
||||
+307
-9
@@ -3,23 +3,69 @@
|
||||
[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]))
|
||||
|
||||
;; A `js/fetch` of `uri` (GET unless `method` is given). A `body` is sent as EDN.
|
||||
(defn- fetch-request [{:keys [uri method body]}]
|
||||
(js/fetch uri (clj->js (cond-> {:method (or method "GET")}
|
||||
body (assoc :headers {"Content-Type" "application/edn"}
|
||||
:body (pr-str body))))))
|
||||
|
||||
(defn- response-map [resp text]
|
||||
{:ok? (.-ok resp) :status (.-status resp) :body text})
|
||||
|
||||
;; Effect: request `uri` (GET unless `method` is given), then dispatch
|
||||
;; `(conj on-response {:ok? bool :status int-or-nil :body string})`. A `body` is sent as EDN.
|
||||
;; Network failures come back as `{:ok? false :status nil :body <message>}`.
|
||||
(rf/reg-fx
|
||||
::fetch
|
||||
(fn [{:keys [uri method body on-response]}]
|
||||
(-> (js/fetch uri (clj->js (cond-> {:method (or method "GET")}
|
||||
body (assoc :headers {"Content-Type" "application/edn"}
|
||||
:body (pr-str body)))))
|
||||
(fn [{:keys [on-response] :as request}]
|
||||
(-> (fetch-request request)
|
||||
(.then (fn [resp]
|
||||
(.then (.text resp)
|
||||
#(rf/dispatch (conj on-response {:ok? (.-ok resp)
|
||||
:status (.-status resp)
|
||||
:body %})))))
|
||||
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))
|
||||
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
|
||||
|
||||
(def ^:private connection-lost {:error "the connection was lost"})
|
||||
|
||||
(defn- read-events!
|
||||
"Dispatches `(conj on-event event)` for each server-sent event (see tbd.ui.sse) in the body read
|
||||
by `reader`, as they arrive. A body that ends without a :done or :error event (the connection
|
||||
dropped) is an :error event, so whoever waits for the end always gets one."
|
||||
[reader on-event]
|
||||
(let [decoder (js/TextDecoder. "utf-8")
|
||||
ended? (atom false)
|
||||
lost! #(when-not @ended?
|
||||
(reset! ended? true)
|
||||
(rf/dispatch (conj on-event connection-lost)))
|
||||
step (fn step [pending]
|
||||
(-> (.read reader)
|
||||
(.then (fn [^js chunk]
|
||||
(if (.-done chunk)
|
||||
(lost!)
|
||||
(let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk)
|
||||
#js {:stream true})))]
|
||||
(doseq [event events]
|
||||
(when (or (:done event) (:error event)) (reset! ended? true))
|
||||
(rf/dispatch (conj on-event event)))
|
||||
(step pending)))))
|
||||
(.catch (fn [_] (lost!)))))]
|
||||
(step "")))
|
||||
|
||||
;; Effect: like ::fetch, for a response that is a stream of server-sent events. While it comes in,
|
||||
;; `(conj on-event event)` is dispatched for each event, as a map (see read-events!). When the
|
||||
;; request fails instead (a network error or a status that isn't 2xx: no stream came),
|
||||
;; `(conj on-response {:ok? false :status int-or-nil :body string})` is dispatched, as ::fetch does.
|
||||
(rf/reg-fx
|
||||
::fetch-stream
|
||||
(fn [{:keys [on-event on-response] :as request}]
|
||||
(-> (fetch-request request)
|
||||
(.then (fn [resp]
|
||||
(if (.-ok resp)
|
||||
(read-events! (.getReader (.-body resp)) on-event)
|
||||
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %)))))))
|
||||
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
|
||||
|
||||
;; Coeffect: the URL's fragment, which says which page to start on.
|
||||
@@ -124,11 +170,18 @@
|
||||
(fn [_ _]
|
||||
{::fetch {:uri "/auth/logout" :method "POST" :on-response [::logout-response]}}))
|
||||
|
||||
(defn- reset-chat
|
||||
"An empty conversation, in a panel that is as open (or closed), and as big, as it was."
|
||||
[db]
|
||||
(assoc db :chat (merge (:chat db/default-db) (select-keys (:chat db) [:open? :size]))))
|
||||
|
||||
(rf/reg-event-db
|
||||
::logout-response
|
||||
(fn [db [_ {:keys [ok?] :as resp}]]
|
||||
(if ok?
|
||||
(assoc db :user {:status :anonymous} :todos (:todos db/default-db))
|
||||
(-> db
|
||||
(assoc :user {:status :anonymous} :todos (:todos db/default-db))
|
||||
reset-chat)
|
||||
(assoc-in db [:todos :error] (error-message resp)))))
|
||||
|
||||
;; --- Todos ---
|
||||
@@ -212,6 +265,251 @@
|
||||
{:db (update-in db [:todos :items] (fn [items] (filterv #(not= id (:id %)) items)))}
|
||||
{:dispatch [::todo-failed resp]})))
|
||||
|
||||
;; --- Chat ---
|
||||
|
||||
;; The chat is a loop when the LLM uses the page's tools (see tbd.ui.model-context): the reply to a
|
||||
;; message can be a request for tool calls instead of (or after) text; the page makes the calls,
|
||||
;; and sends the conversation again, now with their results, for the LLM to go on from. It does
|
||||
;; that until the LLM answers without asking for tools.
|
||||
|
||||
(def ^:private max-sent-messages
|
||||
"How much of the conversation goes to the server with each message (its limit is
|
||||
tbd.chat.schema/max-messages, which this stays within), the most recent part."
|
||||
40)
|
||||
|
||||
(def ^:private max-tool-calls-per-turn
|
||||
"How many tool calls the LLM may make in answer to one message of the user's, before the page
|
||||
stops it. A model that keeps calling tools never answers, and every call is something done on the
|
||||
user's page. (A turn is at most 1 + this many assistant messages and this many results, so it is
|
||||
always inside `max-sent-messages`.)"
|
||||
12)
|
||||
|
||||
(def ^:private max-tool-result-length
|
||||
"The longest result of a tool that goes to the LLM (tbd.chat.schema/max-message-length)."
|
||||
8000)
|
||||
|
||||
(def ^:private truncated " … (truncated)")
|
||||
|
||||
(defn- fit-result
|
||||
"A tool's result text as the content of a message: never empty, and no longer than the server
|
||||
takes."
|
||||
[text]
|
||||
(cond
|
||||
(str/blank? text) "(no output)"
|
||||
(> (count text) max-tool-result-length) (str (subs text 0 (- max-tool-result-length (count truncated)))
|
||||
truncated)
|
||||
:else text))
|
||||
|
||||
(defn- wire-message
|
||||
"A message of the conversation as tbd.chat.schema/Message has it."
|
||||
[{:keys [role content tool-calls tool-call-id]}]
|
||||
(case role
|
||||
"assistant" (cond-> {:role role :content content}
|
||||
(seq tool-calls) (assoc :tool-calls tool-calls))
|
||||
"tool" {:role role :tool-call-id tool-call-id :content content}
|
||||
{:role role :content content}))
|
||||
|
||||
(defn- recent
|
||||
"The most recent `max-sent-messages` of `messages`, without the results of calls whose asking
|
||||
is cut off: the LLM server refuses a result that answers nothing."
|
||||
[messages]
|
||||
(drop-while #(= "tool" (:role %)) (take-last max-sent-messages messages)))
|
||||
|
||||
;; The effect that sends the conversation: it goes with the page being shown (`page`, its id, for
|
||||
;; the LLM to know where the user is) and the tools that page offers the LLM. Both are read from
|
||||
;; the db every time, so a conversation that moves between pages (the LLM's own `navigate`, say)
|
||||
;; always tells the LLM where it is now.
|
||||
(defn- chat-request [db messages]
|
||||
(let [tools (model-context/definitions (:page db))]
|
||||
{:uri "/api/chat" :method "POST"
|
||||
:body (cond-> {:messages (mapv wire-message (recent messages))
|
||||
:page (name (:page db))}
|
||||
(seq tools) (assoc :tools tools))
|
||||
:on-event [::chat-event]
|
||||
:on-response [::chat-response]}))
|
||||
|
||||
(rf/reg-event-db
|
||||
::chat-toggle
|
||||
(fn [db _]
|
||||
(update-in db [:chat :open?] not)))
|
||||
|
||||
;; The panel is dragged to `width` px wide and its conversation `height` px high (the view keeps
|
||||
;; them within the window).
|
||||
(rf/reg-event-db
|
||||
::chat-resize
|
||||
(fn [db [_ width height]]
|
||||
(assoc-in db [:chat :size] {:width width :height height})))
|
||||
|
||||
(rf/reg-event-db
|
||||
::chat-set-input
|
||||
(fn [db [_ input]]
|
||||
(assoc-in db [:chat :input] input)))
|
||||
|
||||
;; Only one message is in flight at a time, and a blank one isn't sent.
|
||||
(rf/reg-event-fx
|
||||
::chat-send
|
||||
(fn [{:keys [db]} _]
|
||||
(let [{:keys [input messages status]} (:chat db)
|
||||
content (str/trim input)]
|
||||
(when (and (not= :loading status) (seq content))
|
||||
(let [messages (conj messages {:role "user" :content content})]
|
||||
{:db (update db :chat assoc :messages messages :input "" :status :loading :error nil
|
||||
:tool-calls-used 0)
|
||||
::fetch-stream (chat-request db messages)})))))
|
||||
|
||||
(defn- only-reasoning?
|
||||
"Whether `message` is a reply that has come to nothing but the reasoning for it: there is nothing
|
||||
in it for the LLM to be sent (the server refuses an assistant message that says and asks for
|
||||
nothing)."
|
||||
[{:keys [role content tool-calls]}]
|
||||
(and (= "assistant" role) (str/blank? content) (empty? tool-calls)))
|
||||
|
||||
(defn- chat-failed
|
||||
"The conversation after a send failed with `message`. If the last message is the user's (nothing
|
||||
of the reply had come, but perhaps some reasoning, which goes), it leaves the conversation again
|
||||
and goes back in the input, so trying once more is pressing Send (and the next message doesn't
|
||||
follow one nobody answered). If part of the reply had come, or the tools' results had been sent,
|
||||
that stays, and the next message follows it."
|
||||
[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: fall
|
||||
;; back to the logged-out view. A response nobody is waiting for (the conversation was reset since,
|
||||
;; by logging out) is dropped.
|
||||
(rf/reg-event-db
|
||||
::chat-response
|
||||
(fn [db [_ {:keys [status] :as resp}]]
|
||||
(cond
|
||||
(not= :loading (get-in db [:chat :status])) db
|
||||
(= 401 status) (-> db (assoc :user {:status :anonymous}) reset-chat)
|
||||
:else (chat-failed db (error-message resp)))))
|
||||
|
||||
(defn- append-to-reply
|
||||
"The conversation's assistant message being written, with `text` added to its content. The first
|
||||
piece starts the message, the rest are added to it."
|
||||
[db text]
|
||||
(update-in db [:chat :messages]
|
||||
(fn [messages]
|
||||
(if (= "assistant" (:role (peek messages)))
|
||||
(update messages (dec (count messages)) update :content str text)
|
||||
(conj messages {:role "assistant" :content text})))))
|
||||
|
||||
(defn- with-tool-calls
|
||||
"The conversation with the calls the LLM asked for: on the reply's text (the message it
|
||||
started), or on a message of their own when it said nothing."
|
||||
[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- finish-reply
|
||||
"The reply is complete. Without calls that is all; with them, they are made (see ::call-tools)
|
||||
and the conversation goes on when they are done, unless this turn has used all the calls it may."
|
||||
[db]
|
||||
(let [{:keys [pending-calls tool-calls-used]} (:chat db)
|
||||
used (+ (or tool-calls-used 0) (count pending-calls))
|
||||
db (assoc-in db [:chat :pending-calls] nil)]
|
||||
(cond
|
||||
(empty? pending-calls)
|
||||
{:db (assoc-in db [:chat :status] :idle)}
|
||||
|
||||
(> used max-tool-calls-per-turn)
|
||||
;; The calls still get their answers, for the conversation to make sense to the LLM later.
|
||||
{:db (-> db
|
||||
(update-in [:chat :messages] with-tool-calls pending-calls)
|
||||
(update-in [:chat :messages] into
|
||||
(for [{:keys [id name]} pending-calls]
|
||||
(tool-message {:id id :name name :error? true
|
||||
:content "not run: too many tool calls in one turn"})))
|
||||
(update :chat assoc :status :idle
|
||||
:error "The assistant made too many tool calls in a row, so it was stopped."))}
|
||||
|
||||
:else
|
||||
{:db (-> db
|
||||
(update-in [:chat :messages] with-tool-calls pending-calls)
|
||||
(assoc-in [:chat :tool-calls-used] used))
|
||||
::call-tools {:page (:page db) :calls pending-calls :on-results [::chat-tool-results]}})))
|
||||
|
||||
(defn- text? [x]
|
||||
(and (string? x) (seq x)))
|
||||
|
||||
;; One event of the reply, as the server sends them (see tbd.chat.routes): {:thinking "..."} for
|
||||
;; the next piece of the model's reasoning (which is not kept: the user only sees that the model
|
||||
;; is thinking), {:content "..."} for the next piece of the reply (the first starts the
|
||||
;; assistant's message, the rest are added to it; one event can have both), {:tool-calls [{:id
|
||||
;; :name :arguments}]} when it asks for tools to be called, and last {:done true} or {:error "..."}.
|
||||
;; Events nobody is waiting for (the conversation was reset since) are dropped.
|
||||
(rf/reg-event-fx
|
||||
::chat-event
|
||||
(fn [{:keys [db]} [_ {:keys [content tool-calls done error]}]]
|
||||
(cond
|
||||
(not= :loading (get-in db [:chat :status])) {:db db}
|
||||
(text? content) {:db (append-to-reply db content)}
|
||||
tool-calls {:db (assoc-in db [:chat :pending-calls] (mapv #(select-keys % [:id :name :arguments])
|
||||
tool-calls))}
|
||||
done (finish-reply db)
|
||||
error {:db (chat-failed db error)}
|
||||
:else {:db db})))
|
||||
|
||||
(defn- call-all
|
||||
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. One after the
|
||||
other: the tools work on the same page (one may need the page the last one opened). Only the
|
||||
tools `page` offers can be called."
|
||||
[page calls]
|
||||
(reduce (fn [results {:keys [id name arguments]}]
|
||||
(.then results
|
||||
(fn [done]
|
||||
(.then (model-context/call! page name arguments)
|
||||
(fn [{:keys [text error?]}]
|
||||
(conj done {:id id :name name :content (fit-result text) :error? error?}))))))
|
||||
(js/Promise.resolve [])
|
||||
calls))
|
||||
|
||||
;; Effect: make the tool calls the LLM asked for, on the tools `page` (the one being shown) offers,
|
||||
;; and dispatch `(conj on-results results)` when all are done: one {:id :name :content :error?}
|
||||
;; for each, in order. A call that can't be made (an unknown tool, one the page doesn't offer,
|
||||
;; arguments that aren't JSON, a tool that fails) is a result with :error?, for the LLM to read.
|
||||
(rf/reg-fx
|
||||
::call-tools
|
||||
(fn [{:keys [page calls on-results]}]
|
||||
(.then (call-all page calls) #(rf/dispatch (conj on-results %)))))
|
||||
|
||||
(defn- answers?
|
||||
"Whether `results` are for the calls the conversation is waiting on. Results nobody waits for
|
||||
(the conversation was reset while the tools ran) are not."
|
||||
[db results]
|
||||
(let [calls (:tool-calls (peek (get-in db [:chat :messages])))]
|
||||
(and (= :loading (get-in db [:chat :status]))
|
||||
(seq calls)
|
||||
(= (map :id calls) (map :id results)))))
|
||||
|
||||
;; The tools have run: their results join the conversation, and it goes to the LLM again.
|
||||
(rf/reg-event-fx
|
||||
::chat-tool-results
|
||||
(fn [{:keys [db]} [_ results]]
|
||||
(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]))}))))
|
||||
|
||||
;; Starts the conversation over. Not while a reply is on its way: it would land in the new one.
|
||||
(rf/reg-event-db
|
||||
::chat-clear
|
||||
(fn [db _]
|
||||
(if (= :loading (get-in db [:chat :status]))
|
||||
db
|
||||
(reset-chat db))))
|
||||
|
||||
;; --- MCP setup page ---
|
||||
|
||||
;; Effect: put `text` on the clipboard. The Clipboard API only exists on secure origins (https
|
||||
|
||||
@@ -0,0 +1,98 @@
|
||||
(ns tbd.ui.model-context
|
||||
"The page's `modelContext`: the tools the page offers to an agent, as WebMCP names it (a page
|
||||
registers tools with `navigator.modelContext` in the browsers that have one). Here it is the
|
||||
registry the page's own chatbot reads. tbd.ui.core registers the tools of tbd.ui.webmcp, which
|
||||
are also offered to an outside agent through the WebMCP widget; the chatbot is the same thing
|
||||
embedded in the page.
|
||||
|
||||
The chatbot passes the tools' metadata (`definitions`, the shape of MCP's `tools/list`) to the
|
||||
LLM along with the conversation. The LLM never runs anything: it answers with the calls it wants
|
||||
made, tbd.ui.events intercepts them, `call!` invokes the tool right here in the page (the same
|
||||
handlers as WebMCP's, so it shows on screen like a user's own doing) and the result goes back to
|
||||
the LLM with the next request, as MCP's `tools/call` result would.
|
||||
|
||||
A tool is {:name :description :input-schema :handler :pages}: `handler` takes its arguments as a
|
||||
map and returns a value or a promise of one. A string is the result as it is, any other data
|
||||
becomes JSON, and throwing (or rejecting) is an error result the agent can read. `pages` is the
|
||||
set of pages (see tbd.ui.pages) the tool is offered on, so the LLM on the games page is not
|
||||
handed the todos' tools; a tool without it is offered on every page. What is offered follows the
|
||||
page being shown: `definitions` and `call!` both take it, and a tool that is not offered on it
|
||||
can neither be listed nor called."
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
(defonce ^:private 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 away: for a test to start from a page that offers none."
|
||||
[]
|
||||
(reset! registry [])
|
||||
nil)
|
||||
|
||||
(defn- offered?
|
||||
"Whether `tool` 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."
|
||||
[page]
|
||||
(into []
|
||||
(comp (filter #(offered? page %))
|
||||
(map (fn [{:keys [name description input-schema]}]
|
||||
(cond-> {:name name :inputSchema input-schema}
|
||||
description (assoc :description description)))))
|
||||
@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,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)]))
|
||||
@@ -7,6 +7,7 @@
|
||||
(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)))
|
||||
|
||||
+183
-8
@@ -175,6 +175,179 @@
|
||||
:error [:p {:role "alert" :style {:color "crimson"}} message]
|
||||
nil))
|
||||
|
||||
(def ^:private chat-green "#28a745")
|
||||
|
||||
(defn- chat-bubble [{:keys [role content]}]
|
||||
(let [user? (= "user" role)]
|
||||
[:div {:style {:align-self (if user? "flex-end" "flex-start")
|
||||
:max-width "85%" :padding "0.4rem 0.6rem" :border-radius "0.5rem"
|
||||
:white-space "pre-wrap" :overflow-wrap "anywhere"
|
||||
:background (if user? chat-green "#f1f1f1")
|
||||
:color (if user? "white" "#222")}}
|
||||
content]))
|
||||
|
||||
(defn- chat-tool-line
|
||||
"A tool the assistant calls, or what came of it, apart from what is said, and in smaller print.
|
||||
All of it shows, wrapped: the conversation scrolls, so it needn't be cut short."
|
||||
[text {:keys [error?]}]
|
||||
[:div {:data-tool true
|
||||
:style {:align-self "flex-start" :max-width "85%"
|
||||
:white-space "pre-wrap" :overflow-wrap "anywhere"
|
||||
:font-family "monospace" :font-size "12px"
|
||||
:color (if error? "crimson" "#777")}}
|
||||
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-message
|
||||
"What was said, as a bubble, and the tool calls the assistant made with it, and their results,
|
||||
as lines between the bubbles."
|
||||
[{:keys [role content tool-calls] :as message}]
|
||||
(if (= "tool" role)
|
||||
[chat-tool-line (result-text message) message]
|
||||
[:<>
|
||||
(when-not (str/blank? content) [chat-bubble message])
|
||||
(for [call tool-calls]
|
||||
^{:key (:id call)} [chat-tool-line (call-text call) nil])]))
|
||||
|
||||
(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))
|
||||
|
||||
(defn- chat-log
|
||||
"The conversation, which follows its end (as the pieces of a reply come in) for as long as it is
|
||||
scrolled to it. Scroll up to read back and it stays where it is, until you send a message or
|
||||
scroll down to the end again (a message sent is among the ones that came since the last render,
|
||||
which may also hold the first of the reply). \"Thinking…\" shows from the sending until the reply's first piece;
|
||||
what the model reasons is not shown."
|
||||
[_chat _size]
|
||||
(let [stuck? (atom true)
|
||||
seen (atom 0)]
|
||||
(fn [{:keys [messages status]} {: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 message]))
|
||||
(when (and (= :loading status) (not= "assistant" (:role (peek messages))))
|
||||
[:div {:role "status" :style {:color "#777"}} "Thinking…"])])))
|
||||
|
||||
(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"}}
|
||||
;; Read-only while waiting (rather than disabled) so it keeps the focus.
|
||||
[:input {:type "text" :name "message" :aria-label "Message" :placeholder "Message"
|
||||
:auto-focus true :auto-complete "off" :read-only loading?
|
||||
: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] :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 (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"}}
|
||||
(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
|
||||
:games [:<> [tic-tac-toe] [calculator]]
|
||||
@@ -196,11 +369,13 @@
|
||||
(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])]]))
|
||||
[:<>
|
||||
[: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]]))
|
||||
|
||||
+82
-44
@@ -7,13 +7,21 @@
|
||||
the form, press a button, tick a box) by dispatching the same re-frame events the views do, so
|
||||
everything shows on screen, and reads what the page shows from the app-db.
|
||||
|
||||
The same tools are registered with tbd.ui.model-context (by tbd.ui.core), which is how the page's
|
||||
own chatbot offers them to its LLM and calls them, the ones of the page being shown (see
|
||||
`tools`): this ns says what the tools are, and has the WebMCP way of offering them all to an
|
||||
agent outside the page.
|
||||
|
||||
A tool takes its arguments as a map and returns a value or a promise of one: a string, or data
|
||||
that becomes JSON. Throwing (or rejecting) becomes an error result the agent can read. Input
|
||||
schemas are JSON Schema, written here: the UI has no Malli to share with the server's."
|
||||
(: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.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 ---
|
||||
@@ -58,16 +66,22 @@
|
||||
(-> (settled #(not= :unknown (get-in % [:user :status])) "the login state")
|
||||
(.then #(:user %))))
|
||||
|
||||
(defn- logged-in-todos
|
||||
"A promise of the todo list as the page shows it, or a rejection if there is no login (the page
|
||||
hides the todos then) or the list could not be loaded."
|
||||
[]
|
||||
(defn- logged-in!
|
||||
"A promise that is fulfilled once the page knows someone is logged in, or rejected if no one is
|
||||
(`what` is what needs the login: the page hides it then) or the page can't tell."
|
||||
[what]
|
||||
(-> (known-user)
|
||||
(.then (fn [{:keys [status message]}]
|
||||
(case status
|
||||
:logged-in nil
|
||||
:anonymous (fail! "not logged in: log in on the page to use the todos")
|
||||
:error (fail! (str "could not tell who is logged in: " message)))))
|
||||
:anonymous (fail! (str "not logged in: log in on the page to use " what))
|
||||
:error (fail! (str "could not tell who is logged in: " message)))))))
|
||||
|
||||
(defn- logged-in-todos
|
||||
"A promise of the todo list as the page shows it, or a rejection if there is no login (the page
|
||||
hides the todos then) or the list could not be loaded."
|
||||
[]
|
||||
(-> (logged-in! "the todos")
|
||||
(.then #(settled (fn [d] (contains? #{:ok :error} (get-in d [:todos :status]))) "the todos"))
|
||||
(.then (fn [d]
|
||||
(let [{:keys [status items error]} (:todos d)]
|
||||
@@ -104,6 +118,18 @@
|
||||
|
||||
(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]}]
|
||||
@@ -185,8 +211,10 @@
|
||||
"the todo to go")))
|
||||
(.then (fn [_] "deleted"))))
|
||||
|
||||
;; Tic-tac-toe is moves taken in turns: X, then O, on the same board. The agent can move for
|
||||
;; either side, so every result says whose turn it is.
|
||||
;; Tic-tac-toe is moves taken in turns: X, then O, on the same board. A person plays on the same
|
||||
;; board, so a move names the side it is for, and is refused when it is not that side's turn: an
|
||||
;; agent that lost track of whose turn it is cannot play the person's move (or both sides).
|
||||
;; Every result says whose turn it is.
|
||||
|
||||
(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
|
||||
@@ -204,18 +232,17 @@
|
||||
(tic-tac-toe-state))
|
||||
|
||||
(defn- move-tic-tac-toe
|
||||
"Presses cell `cell`, which moves for whoever's turn it is. With `player`, only if it is that
|
||||
player's turn: a guard against moving for the wrong side."
|
||||
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn."
|
||||
[{:keys [cell player]}]
|
||||
(when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 8))
|
||||
(fail! "invalid arguments: cell must be an integer from 0 to 8"))
|
||||
(when-not (contains? #{nil "x" "o"} player)
|
||||
(when-not (contains? #{"x" "o"} player)
|
||||
(fail! "invalid arguments: player must be \"x\" or \"o\""))
|
||||
(let [{:keys [board turn]} (:ttt (db))]
|
||||
(when (tictactoe/outcome board)
|
||||
(fail! "the game is over: start a new game"))
|
||||
(when (and player (not= player (name turn)))
|
||||
(fail! (str "it is " (name turn) "'s turn, not " player "'s")))
|
||||
(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! :games)
|
||||
@@ -235,75 +262,94 @@
|
||||
(def ^:private todo-id {:type "integer" :description "The todo's id"})
|
||||
|
||||
(def tools
|
||||
"The tools, as {:name :description :input-schema :handler}."
|
||||
[{:name "ping" :description "Health check: returns pong"
|
||||
"The tools, as {:name :description :input-schema :handler :pages}. `pages` is where the page's
|
||||
own chatbot is offered the tool (see tbd.ui.model-context): the tools of a page's content are
|
||||
only offered on that page, and the rest (no `pages`) on every page. An agent outside the page,
|
||||
through WebMCP, is offered all of them."
|
||||
[{:name "ping" :description "Health check: returns pong. Almost never useful: do not call it to look busy"
|
||||
:input-schema (object-schema {} []) :handler ping}
|
||||
|
||||
{:name "whoami"
|
||||
:description "Says who is logged in on this page, if anyone"
|
||||
:input-schema (object-schema {} []) :handler whoami}
|
||||
|
||||
{:name "get_calculator"
|
||||
{:name "navigate"
|
||||
:description (str "Opens one of the pages of the app, as a click on its tab would, and returns the page "
|
||||
"that is shown now (JSON). 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 #{:games}
|
||||
:description (str "What the calculator form on this page holds (JSON): the x and y in its fields, and "
|
||||
"the result it is showing (status idle, loading, ok with the sum, or error with the message)")
|
||||
:input-schema (object-schema {} []) :handler get-calculator}
|
||||
|
||||
{:name "add"
|
||||
:description "Types two numbers into the calculator form, presses Add, and returns the sum the page shows (JSON)"
|
||||
{:name "add" :pages #{:games}
|
||||
:description (str "Adds two numbers: types them into the calculator form, presses Add, and returns the sum "
|
||||
"the page shows (JSON). Only for arithmetic, not for adding items to a list")
|
||||
:input-schema (object-schema {:x {:type "number" :description "The first number"}
|
||||
:y {:type "number" :description "The second number"}}
|
||||
["x" "y"])
|
||||
:handler add}
|
||||
|
||||
{:name "list_todos"
|
||||
{:name "list_todos" :pages #{:todos}
|
||||
: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"
|
||||
{:name "get_todo" :pages #{:todos}
|
||||
:description "Gets one of the todos this page shows, by id (JSON)"
|
||||
:input-schema (object-schema {:id todo-id} ["id"]) :handler get-todo}
|
||||
|
||||
{:name "create_todo"
|
||||
{:name "create_todo" :pages #{:todos}
|
||||
:description "Types a title into the new-todo field, presses Add, and returns the todo that was created (JSON)"
|
||||
:input-schema (object-schema {:title {:type "string" :minLength 1 :maxLength 200
|
||||
:description "What needs doing"}}
|
||||
["title"])
|
||||
:handler create-todo}
|
||||
|
||||
{:name "set_todo_done"
|
||||
{:name "set_todo_done" :pages #{:todos}
|
||||
:description "Ticks or unticks a todo's checkbox and returns the todo (JSON)"
|
||||
:input-schema (object-schema {:id todo-id
|
||||
:done {:type "boolean" :description "true to tick it off, false to untick it"}}
|
||||
["id" "done"])
|
||||
:handler set-todo-done}
|
||||
|
||||
{:name "delete_todo"
|
||||
:description "Presses a todo's Delete button"
|
||||
{:name "delete_todo" :pages #{:todos}
|
||||
:description (str "Deletes a todo for good, by pressing its Delete button. Find the id with list_todos first; "
|
||||
"never guess one, and never delete a todo the user did not clearly point at")
|
||||
:input-schema (object-schema {:id todo-id} ["id"])
|
||||
:handler delete-todo}
|
||||
|
||||
{:name "get_tic_tac_toe"
|
||||
{:name "get_tic_tac_toe" :pages #{:games}
|
||||
:description (str "The tic-tac-toe game on this page (JSON): board (9 cells, row by row, cell 0 the top left "
|
||||
"and cell 8 the bottom right; null when empty, else \"x\" or \"o\"), turn (whose move it "
|
||||
"is, \"x\" or \"o\": X goes first, and they alternate) and status (in_progress, won or draw; "
|
||||
"when won, also winner and line). A person moves on the same board, so check the turn "
|
||||
"before you move")
|
||||
"before you move, and only move for your own side")
|
||||
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
|
||||
|
||||
{:name "move_tic_tac_toe"
|
||||
:description (str "Presses a cell of the tic-tac-toe board, which moves for whoever's turn it is, and returns "
|
||||
"the game as get_tic_tac_toe does (including whose turn is next). Fails if the cell is "
|
||||
"taken or the game is over")
|
||||
{:name "move_tic_tac_toe" :pages #{:games}
|
||||
:description (str "Presses a cell of the tic-tac-toe board as `player`, your side, and returns the game as "
|
||||
"get_tic_tac_toe does (including whose turn is next). Fails, and changes nothing, if it "
|
||||
"is not your side's turn (the other side is the person's: wait for them to move), the "
|
||||
"cell is taken or the game is over. Never move for the other side")
|
||||
:input-schema (object-schema {:cell {:type "integer" :minimum 0 :maximum 8
|
||||
:description "0 is the top left, 2 the top right, 8 the bottom right"}
|
||||
:player {:type "string" :enum ["x" "o"]
|
||||
:description (str "Optional: the side you are moving for. The move is "
|
||||
"refused if it is the other side's turn")}}
|
||||
["cell"])
|
||||
:description (str "The side you play. The move is refused if it "
|
||||
"is the other side's turn")}}
|
||||
["cell" "player"])
|
||||
:handler move-tic-tac-toe}
|
||||
|
||||
{:name "new_tic_tac_toe_game"
|
||||
{:name "new_tic_tac_toe_game" :pages #{:games}
|
||||
:description "Presses New game: clears the tic-tac-toe board, X to move (JSON, as get_tic_tac_toe)"
|
||||
:input-schema (object-schema {} []) :handler new-tic-tac-toe-game}])
|
||||
|
||||
@@ -317,21 +363,13 @@
|
||||
#js {"content" content "isError" true}
|
||||
#js {"content" content})))
|
||||
|
||||
(defn- ->text [value]
|
||||
(cond
|
||||
(string? value) value
|
||||
(nil? value) "ok"
|
||||
:else (js/JSON.stringify (clj->js value))))
|
||||
|
||||
(defn- execute
|
||||
"A WebMCP `execute` callback for `handler`: runs it on the arguments, and turns what it
|
||||
returns, or the error it throws, into a tool result."
|
||||
[handler]
|
||||
(fn [args]
|
||||
(-> (js/Promise.resolve)
|
||||
(.then #(handler (js->clj args :keywordize-keys true)))
|
||||
(.then (fn [value] (text-result (->text value) false)))
|
||||
(.catch (fn [e] (text-result (or (some-> e (aget "message")) (str e)) true))))))
|
||||
(-> (model-context/run handler (js->clj args :keywordize-keys true))
|
||||
(.then (fn [{:keys [text error?]}] (text-result text error?))))))
|
||||
|
||||
(defn register-tools!
|
||||
"Registers `tools` on `mcp`, a WebMCP instance: `registerTool(name, description, inputSchema,
|
||||
|
||||
@@ -3,6 +3,7 @@
|
||||
[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]))
|
||||
|
||||
@@ -36,6 +37,7 @@
|
||||
(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)
|
||||
@@ -53,6 +55,8 @@
|
||||
(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")
|
||||
;; A tool, as the agent's client calls it.
|
||||
(let [ping (.-execute (.get (.-availableTools ^js (widget)) "ping"))]
|
||||
(-> (ping #js {})
|
||||
|
||||
@@ -4,6 +4,7 @@
|
||||
[re-frame.db :as rf-db]
|
||||
[tbd.ui.db :as db]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.model-context :as model-context]
|
||||
[tbd.ui.test-util :as tu]))
|
||||
|
||||
;; The handlers run for real; what they ask the outside world for (a request, the clipboard, a
|
||||
@@ -19,8 +20,11 @@
|
||||
|
||||
(use-fixtures :each
|
||||
tu/url-fixture
|
||||
{:before (fn [] (reset! effects []) (reset! queued []))}
|
||||
{:before (fn [] (reset! effects []) (reset! queued []) (model-context/clear!))
|
||||
:after model-context/clear!}
|
||||
(tu/stub-effects-fixture {::events/fetch (record ::events/fetch)
|
||||
::events/fetch-stream (record ::events/fetch-stream)
|
||||
::events/call-tools (record ::events/call-tools)
|
||||
::events/copy-to-clipboard (record ::events/copy-to-clipboard)
|
||||
:dispatch-later (record :dispatch-later)
|
||||
:dispatch #(swap! queued conj %)}))
|
||||
@@ -37,9 +41,10 @@
|
||||
(defn- app-db [] @rf-db/app-db)
|
||||
|
||||
(defn- requests
|
||||
"The requests asked for so far, as {:uri :method :body :on-response}."
|
||||
"The requests asked for so far, as {:uri :method :body :on-response}. (Those for a stream of
|
||||
events also have :on-event.)"
|
||||
[]
|
||||
(mapv second (filter (comp #{::events/fetch} first) @effects)))
|
||||
(mapv second (filter (comp #{::events/fetch ::events/fetch-stream} first) @effects)))
|
||||
|
||||
(defn- last-request [] (last (requests)))
|
||||
|
||||
@@ -268,6 +273,566 @@
|
||||
(is (= {:status :anonymous} (:user (app-db))) (str event))
|
||||
(is (= (:todos db/default-db) (:todos (app-db))) "the todos are hidden and forgotten"))))
|
||||
|
||||
;; --- Chat ---
|
||||
|
||||
(defn- chat [] (:chat (app-db)))
|
||||
|
||||
(defn- say!
|
||||
"Types `text` into the chat input and sends it."
|
||||
[text]
|
||||
(dispatch! [::events/chat-set-input text])
|
||||
(dispatch! [::events/chat-send]))
|
||||
|
||||
(defn- event!
|
||||
"The stream the last request asked for delivers `event`."
|
||||
[event]
|
||||
(dispatch! (conj (:on-event (last-request)) event)))
|
||||
|
||||
(defn- reply!
|
||||
"The stream delivers `pieces` of the reply, and ends."
|
||||
[& pieces]
|
||||
(doseq [piece pieces] (event! {:content piece}))
|
||||
(event! {:done true}))
|
||||
|
||||
(deftest chat-toggle-test
|
||||
(start!)
|
||||
(is (false? (:open? (chat))))
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(is (true? (:open? (chat))))
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(is (false? (:open? (chat)))))
|
||||
|
||||
(deftest chat-send-test
|
||||
(logged-in! [])
|
||||
(say! " hello there ")
|
||||
(testing "the trimmed message joins the conversation and goes to the server, for a stream back"
|
||||
(is (= [::events/fetch-stream
|
||||
{:uri "/api/chat" :method "POST"
|
||||
:body {:messages [{:role "user" :content "hello there"}] :page "games"}
|
||||
:on-event [::events/chat-event]
|
||||
:on-response [::events/chat-response]}]
|
||||
(last @effects)))
|
||||
(is (= {:messages [{:role "user" :content "hello there"}] :input "" :status :loading :error nil}
|
||||
(select-keys (chat) [:messages :input :status :error]))))
|
||||
(testing "only one message is in flight, so sending again does nothing"
|
||||
(say! "and another")
|
||||
(is (= 1 (count (requests))))
|
||||
(is (= "and another" (:input (chat)))))
|
||||
(testing "the reply joins the conversation, and the next message carries all of it"
|
||||
(reply! "Hi!")
|
||||
(is (= :idle (:status (chat))))
|
||||
(dispatch! [::events/chat-set-input "how are you"])
|
||||
(dispatch! [::events/chat-send])
|
||||
(is (= [{:role "user" :content "hello there"}
|
||||
{:role "assistant" :content "Hi!"}
|
||||
{:role "user" :content "how are you"}]
|
||||
(get-in (last-request) [:body :messages])))))
|
||||
|
||||
(deftest chat-streaming-reply-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(testing "the model's reasoning is not kept, and it keeps waiting"
|
||||
(event! {:thinking "Let me "})
|
||||
(event! {:thinking "think."})
|
||||
(is (= [{:role "user" :content "hello"}] (:messages (chat))))
|
||||
(is (= :loading (:status (chat)))))
|
||||
(testing "the first piece of the reply, and the ones that follow, are added to that message"
|
||||
(event! {:content "Hel"})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}]
|
||||
(:messages (chat))))
|
||||
(event! {:content "lo, "})
|
||||
(event! {:content "world"})
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
(:messages (chat))))
|
||||
(is (= :loading (:status (chat))) "it isn't over until it says so"))
|
||||
(testing "another message can't be sent while the reply is coming in"
|
||||
(say! "and another")
|
||||
(is (= 1 (count (requests)))))
|
||||
(testing "done ends it"
|
||||
(event! {:done true})
|
||||
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
(:messages (chat)))))
|
||||
(testing "events that come after the end are dropped"
|
||||
(event! {:content "late"})
|
||||
(is (= "Hello, world" (:content (last (:messages (chat)))))))
|
||||
(testing "the next message has the conversation so far"
|
||||
(say! "again")
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hello, world"}
|
||||
{:role "user" :content "again"}]
|
||||
(get-in (last-request) [:body :messages])))))
|
||||
|
||||
(deftest chat-thinking-and-text-in-one-event-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(event! {:thinking "hm" :content "Hi"})
|
||||
(event! {:thinking "m" :content "!"})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}]
|
||||
(:messages (chat))))
|
||||
(testing "an empty piece changes nothing"
|
||||
(event! {:thinking "" :content ""})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}]
|
||||
(:messages (chat))))))
|
||||
|
||||
(deftest chat-thinking-is-never-kept-test
|
||||
;; The reasoning of each reply of a turn, before and after tools, leaves nothing in the conversation.
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(event! {:thinking "first"})
|
||||
(event! {:tool-calls [{:id "c1" :name "ping" :arguments "{}"}]})
|
||||
(event! {:done true})
|
||||
(dispatch! [::events/chat-tool-results [{:id "c1" :name "ping" :content "pong" :error? false}]])
|
||||
(event! {:thinking "second"})
|
||||
(event! {:content "done"})
|
||||
(is (= [["user" nil] ["assistant" nil] ["tool" nil] ["assistant" nil]]
|
||||
(map (juxt :role :thinking) (:messages (chat)))))
|
||||
(is (not-any? #(re-find #"first|second" (pr-str %)) (:messages (chat)))))
|
||||
|
||||
(deftest chat-blank-message-test
|
||||
(logged-in! [])
|
||||
(say! " ")
|
||||
(is (= [] (requests)) "a blank message isn't sent")
|
||||
(is (= [] (:messages (chat)))))
|
||||
|
||||
(deftest chat-sends-the-recent-conversation-test
|
||||
(logged-in! [])
|
||||
(swap! rf-db/app-db assoc-in [:chat :messages]
|
||||
(vec (for [i (range 60)] {:role (if (even? i) "user" "assistant") :content (str i)})))
|
||||
(say! "latest")
|
||||
(let [sent (get-in (last-request) [:body :messages])]
|
||||
(is (= 40 (count sent)) "what the server accepts")
|
||||
(is (vector? sent))
|
||||
(is (= "latest" (:content (last sent))))
|
||||
(is (= "21" (:content (first sent))) "the oldest part is what is left out")))
|
||||
|
||||
(deftest chat-failure-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(answer! 503 {:error "chat is not configured"})
|
||||
(testing "the message goes back in the input, and the error is shown"
|
||||
(is (= {:messages [] :input "hello" :status :idle :error "chat is not configured"}
|
||||
(select-keys (chat) [:messages :input :status :error]))))
|
||||
(testing "sending again clears the error, and then it can work"
|
||||
(dispatch! [::events/chat-send])
|
||||
(is (nil? (:error (chat))))
|
||||
(reply! "Hi!")
|
||||
(is (= ["hello" "Hi!"] (mapv :content (:messages (chat)))))))
|
||||
|
||||
(deftest chat-network-failure-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(dispatch! (conj (:on-response (last-request)) {:ok? false :status nil :body "Failed to fetch"}))
|
||||
(is (= {:messages [] :input "hello" :status :idle :error "Failed to fetch"}
|
||||
(select-keys (chat) [:messages :input :status :error]))))
|
||||
|
||||
(deftest chat-failure-in-the-stream-test
|
||||
(testing "before any of the reply: like a request that failed, the message goes back in the input"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(event! {:thinking "hmm"})
|
||||
(event! {:error "the LLM server took too long to answer"})
|
||||
(is (= {:messages [] :input "hello" :status :idle :error "the LLM server took too long to answer"}
|
||||
(select-keys (chat) [:messages :input :status :error]))))
|
||||
(testing "in the middle of the reply: what came stays, with the error, and the conversation goes on from it"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(event! {:content "Hel"})
|
||||
(event! {:error "the connection was lost"})
|
||||
(is (= {:messages [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}]
|
||||
:input "" :status :idle :error "the connection was lost"}
|
||||
(select-keys (chat) [:messages :input :status :error])))
|
||||
(say! "again")
|
||||
(is (nil? (:error (chat))))
|
||||
(is (= ["hello" "Hel" "again"] (map :content (get-in (last-request) [:body :messages]))))))
|
||||
|
||||
(deftest chat-expired-session-test
|
||||
(logged-in! [])
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(say! "hello")
|
||||
(answer! 401 {:error "login required"})
|
||||
(is (= {:status :anonymous} (:user (app-db))) "falls back to the logged-out view")
|
||||
(is (= (assoc (:chat db/default-db) :open? true) (chat)) "the conversation is forgotten, the panel stays open"))
|
||||
|
||||
(deftest chat-clear-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(testing "not while a reply is on its way"
|
||||
(dispatch! [::events/chat-clear])
|
||||
(is (= [{:role "user" :content "hello"}] (:messages (chat))))
|
||||
(event! {:content "Hi"})
|
||||
(dispatch! [::events/chat-clear])
|
||||
(is (= 2 (count (:messages (chat))))))
|
||||
(event! {:done true})
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(dispatch! [::events/chat-clear])
|
||||
(is (= (assoc (:chat db/default-db) :open? true) (chat)) "starts over, and the panel stays as it was"))
|
||||
|
||||
(deftest chat-resize-test
|
||||
(logged-in! [])
|
||||
(is (= {:width 320 :height 256} (:size (chat))) "the size it starts with")
|
||||
(dispatch! [::events/chat-resize 500 400])
|
||||
(is (= {:width 500 :height 400} (:size (chat))))
|
||||
(testing "the panel keeps its size when the conversation starts over"
|
||||
(say! "hello")
|
||||
(reply! "Hi!")
|
||||
(dispatch! [::events/chat-clear])
|
||||
(is (empty? (:messages (chat))))
|
||||
(is (= {:width 500 :height 400} (:size (chat)))))
|
||||
(testing "and when its owner logs out"
|
||||
(dispatch! [::events/logout])
|
||||
(answer! 200 {:logged-out true})
|
||||
(is (= {:width 500 :height 400} (:size (chat))))))
|
||||
|
||||
(deftest chat-forgotten-on-logout-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(reply! "Hi!")
|
||||
(say! "and again")
|
||||
(let [request (last-request)]
|
||||
(event! {:content "partial"})
|
||||
(dispatch! [::events/logout])
|
||||
(answer! 200 {:logged-out true})
|
||||
(is (= (:chat db/default-db) (chat)))
|
||||
(testing "what the stream still delivers is dropped"
|
||||
(dispatch! (conj (:on-event request) {:content "late"}))
|
||||
(dispatch! (conj (:on-event request) {:done true}))
|
||||
(dispatch! (conj (:on-response request) {:ok? false :status 502 :body "{:error \"x\"}"}))
|
||||
(is (= (:chat db/default-db) (chat))))))
|
||||
|
||||
;; --- Chat: the LLM uses the page's tools ---
|
||||
|
||||
(def ^:private add-schema {:type "object" :properties {:x {:type "number"}} :required ["x"]})
|
||||
|
||||
(defn- call [id tool-name arguments]
|
||||
{:id id :name tool-name :arguments arguments})
|
||||
|
||||
(defn- tool-calls-asked
|
||||
"What the page was asked to do, by the ::call-tools effects so far: {:page :calls :on-results}."
|
||||
[]
|
||||
(mapv second (filter (comp #{::events/call-tools} first) @effects)))
|
||||
|
||||
(defn- asks!
|
||||
"The stream delivers a request for `calls`, and ends."
|
||||
[& calls]
|
||||
(event! {:tool-calls (vec calls)})
|
||||
(event! {:done true}))
|
||||
|
||||
(defn- ran!
|
||||
"The tools the last request for calls asked for have run, with these results: [id name content
|
||||
error?] each."
|
||||
[& results]
|
||||
(dispatch! (conj (:on-results (last (tool-calls-asked)))
|
||||
(mapv (fn [[id tool-name content error?]]
|
||||
{:id id :name tool-name :content content :error? error?})
|
||||
results))))
|
||||
|
||||
(deftest chat-offers-the-tools-test
|
||||
(logged-in! [])
|
||||
(testing "no tools on the page, none offered"
|
||||
(say! "hi")
|
||||
(is (not (contains? (:body (last-request)) :tools))))
|
||||
(testing "the page's tools go along with the conversation, as MCP describes them"
|
||||
(reply! "hello")
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(say! "again")
|
||||
(is (= [{:name "add" :description "Adds" :inputSchema add-schema}]
|
||||
(:tools (:body (last-request)))))))
|
||||
|
||||
(deftest chat-says-which-page-it-is-on-test
|
||||
(logged-in! [])
|
||||
(testing "the page the user is on goes along with the conversation"
|
||||
(say! "hi")
|
||||
(is (= "games" (:page (:body (last-request))))))
|
||||
(testing "and follows them, or the LLM itself, to the next page"
|
||||
(reply! "hello")
|
||||
(dispatch! [::events/navigate :ai-setup])
|
||||
(say! "again")
|
||||
(is (= "ai-setup" (:page (:body (last-request))))))
|
||||
(testing "a page the LLM opened with its tools is the page its next request comes from"
|
||||
(reply! "hello")
|
||||
(model-context/register! [{:name "go" :description "Opens the todos" :input-schema add-schema
|
||||
:handler identity}])
|
||||
(say! "go to the todos")
|
||||
(asks! (call "c1" "go" "{}"))
|
||||
(dispatch! [::events/navigate :todos]) ; what the tool did
|
||||
|
||||
(ran! ["c1" "go" "ok" false])
|
||||
(is (= "todos" (:page (:body (last-request)))))))
|
||||
|
||||
(deftest chat-offers-the-tools-of-the-page-test
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "ping" :description "Pings" :input-schema add-schema :handler identity}
|
||||
{:name "add" :pages #{:games} :description "Adds" :input-schema add-schema :handler identity}
|
||||
{:name "list_todos" :pages #{:todos} :description "Lists" :input-schema add-schema
|
||||
:handler identity}])
|
||||
(let [offered (fn [] (map :name (:tools (:body (last-request)))))]
|
||||
(testing "on a page, its tools and those of every page are offered"
|
||||
(say! "hi")
|
||||
(is (= :games (:page (app-db))))
|
||||
(is (= ["ping" "add"] (offered))))
|
||||
(testing "the tools follow the page the user is on when the message is sent"
|
||||
(reply! "hello")
|
||||
(dispatch! [::events/navigate :todos])
|
||||
(say! "again")
|
||||
(is (= ["ping" "list_todos"] (offered))))
|
||||
(testing "a page with no tools of its own is offered the tools of every page"
|
||||
(reply! "hello")
|
||||
(dispatch! [::events/navigate :ai-setup])
|
||||
(say! "once more")
|
||||
(is (= ["ping"] (offered))))))
|
||||
|
||||
(deftest chat-tool-calls-go-by-the-page-test
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :pages #{:games} :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(dispatch! [::events/navigate :todos])
|
||||
(say! "1+2?")
|
||||
(asks! (call "c1" "add" "{}"))
|
||||
(testing "the calls are made on the tools of the page the user is on, not those of the first page"
|
||||
(is (= [:todos] (map :page (tool-calls-asked)))))
|
||||
(testing "the follow-up request follows the page too: the user may have gone elsewhere meanwhile"
|
||||
(dispatch! [::events/navigate :games])
|
||||
(ran! ["c1" "add" "tool not available on this page: add" true])
|
||||
(is (= ["add"] (map :name (:tools (:body (last-request))))))))
|
||||
|
||||
(deftest chat-tool-call-test
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(say! "1+2?")
|
||||
(testing "while the model reasons or writes a call, nothing is done, and the conversation has neither"
|
||||
(event! {:thinking "I should add."})
|
||||
(event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]})
|
||||
(is (= [{:role "user" :content "1+2?"}] (:messages (chat))))
|
||||
(is (= [] (tool-calls-asked))))
|
||||
(testing "when the reply is over, the calls join the conversation and are made"
|
||||
(event! {:done true})
|
||||
(is (= [{:role "user" :content "1+2?"}
|
||||
{:role "assistant" :content ""
|
||||
:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}]
|
||||
(:messages (chat))))
|
||||
(is (= :loading (:status (chat))) "the LLM still has to answer")
|
||||
(is (= [{:page :games :calls [(call "c1" "add" "{\"x\":1,\"y\":2}")] :on-results [::events/chat-tool-results]}]
|
||||
(tool-calls-asked)))
|
||||
(is (= 1 (count (requests))) "nothing is sent while the tools run"))
|
||||
(testing "another message can't be sent meanwhile"
|
||||
(say! "and another")
|
||||
(is (= 1 (count (requests)))))
|
||||
(testing "the results join the conversation, and go to the LLM, calls and all"
|
||||
(ran! ["c1" "add" "3" false])
|
||||
(is (= {:role "tool" :tool-call-id "c1" :name "add" :content "3" :error? false}
|
||||
(last (:messages (chat)))))
|
||||
(is (= 2 (count (requests))))
|
||||
(is (= [{:role "user" :content "1+2?"}
|
||||
{:role "assistant" :content "" :tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}
|
||||
{:role "tool" :tool-call-id "c1" :content "3"}]
|
||||
(get-in (last-request) [:body :messages])) "as the server has them: only what the LLM needs")
|
||||
(is (= 1 (count (:tools (:body (last-request))))) "and the tools are still on offer"))
|
||||
(testing "the answer is a new message, and ends it"
|
||||
(reply! "It's " "3.")
|
||||
(is (= [{:role "assistant" :content "It's 3."}] (take-last 1 (:messages (chat)))))
|
||||
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
|
||||
(is (nil? (:pending-calls (chat))))))
|
||||
|
||||
(deftest chat-tool-call-with-text-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(event! {:content "Let me "})
|
||||
(event! {:content "check."})
|
||||
(asks! (call "a" "ping" "{}") (call "b" "whoami" ""))
|
||||
(testing "the calls are made on the message that says what it does, in order"
|
||||
(is (= [{:role "user" :content "hi"}
|
||||
{:role "assistant" :content "Let me check."
|
||||
:tool-calls [(call "a" "ping" "{}") (call "b" "whoami" "")]}]
|
||||
(:messages (chat))))
|
||||
(is (= [(call "a" "ping" "{}") (call "b" "whoami" "")] (:calls (last (tool-calls-asked))))))
|
||||
(testing "their results follow in the same order, one message each"
|
||||
(ran! ["a" "ping" "pong" false] ["b" "whoami" "not logged in" false])
|
||||
(is (= [["tool" "a"] ["tool" "b"]]
|
||||
(map (juxt :role :tool-call-id) (take-last 2 (:messages (chat))))))))
|
||||
|
||||
(deftest chat-tool-calls-go-on-test
|
||||
(logged-in! [])
|
||||
(say! "do it")
|
||||
(testing "the LLM may ask again after the results, and again, until it answers"
|
||||
(asks! (call "a" "ping" "{}"))
|
||||
(ran! ["a" "ping" "pong" false])
|
||||
(asks! (call "b" "ping" "{}"))
|
||||
(ran! ["b" "ping" "pong" false])
|
||||
(is (= 3 (count (requests))))
|
||||
(is (= :loading (:status (chat))))
|
||||
(reply! "Done.")
|
||||
(is (= ["user" "assistant" "tool" "assistant" "tool" "assistant"] (map :role (:messages (chat)))))
|
||||
(is (= :idle (:status (chat)))))
|
||||
(testing "a new message starts a new turn, with all the calls it may make"
|
||||
(dispatch! [::events/chat-set-input "again"])
|
||||
(dispatch! [::events/chat-send])
|
||||
(is (zero? (:tool-calls-used (chat))))))
|
||||
|
||||
(deftest chat-tool-call-budget-test
|
||||
(logged-in! [])
|
||||
(say! "go wild")
|
||||
(testing "a turn may make 12 calls, as many rounds as it takes"
|
||||
(dotimes [i 4]
|
||||
(asks! (call (str "a" i) "ping" "{}") (call (str "b" i) "ping" "{}") (call (str "c" i) "ping" "{}"))
|
||||
(ran! [(str "a" i) "ping" "pong" false] [(str "b" i) "ping" "pong" false] [(str "c" i) "ping" "pong" false]))
|
||||
(is (= 12 (:tool-calls-used (chat))))
|
||||
(is (= :loading (:status (chat))))
|
||||
(is (= 5 (count (requests))))
|
||||
(is (<= (count (get-in (last-request) [:body :messages])) 40) "and it all still fits what the server takes"))
|
||||
(testing "one more is too many: it is answered, but not made, and the turn is over"
|
||||
(asks! (call "z" "ping" "{}"))
|
||||
(is (= 4 (count (tool-calls-asked))) "no more asked of the page")
|
||||
(is (= 5 (count (requests))) "nor of the LLM")
|
||||
(is (= {:role "tool" :tool-call-id "z" :name "ping" :content "not run: too many tool calls in one turn"
|
||||
:error? true}
|
||||
(last (:messages (chat)))) "the conversation stays whole: every call has its answer")
|
||||
(is (= "assistant" (:role (nth (:messages (chat)) (- (count (:messages (chat))) 2)))))
|
||||
(is (= {:status :idle :error "The assistant made too many tool calls in a row, so it was stopped."}
|
||||
(select-keys (chat) [:status :error]))))
|
||||
(testing "the next message goes on from there"
|
||||
(say! "ok, stop")
|
||||
(is (nil? (:error (chat))))
|
||||
(is (zero? (:tool-calls-used (chat))))
|
||||
(is (= "user" (:role (last (get-in (last-request) [:body :messages])))))))
|
||||
|
||||
(deftest chat-tool-results-nobody-waits-for-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(asks! (call "a" "ping" "{}"))
|
||||
(let [asked (last (tool-calls-asked))]
|
||||
(testing "results for other calls than the ones asked for are dropped"
|
||||
(dispatch! (conj (:on-results asked) [{:id "other" :name "ping" :content "pong" :error? false}]))
|
||||
(is (= 1 (count (requests))))
|
||||
(is (= "assistant" (:role (last (:messages (chat)))))))
|
||||
(testing "and so are results that come when the conversation was reset meanwhile"
|
||||
(dispatch! [::events/logout])
|
||||
(answer! 200 {:logged-out true})
|
||||
(dispatch! (conj (:on-results asked) [{:id "a" :name "ping" :content "pong" :error? false}]))
|
||||
(is (= 1 (count (filter #(= "/api/chat" (:uri %)) (requests)))) "nothing more went to the LLM")
|
||||
(is (= (:chat db/default-db) (chat))))))
|
||||
|
||||
(deftest chat-tool-results-are-answered-once-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(asks! (call "a" "ping" "{}"))
|
||||
(ran! ["a" "ping" "pong" false])
|
||||
(ran! ["a" "ping" "pong" false])
|
||||
(is (= 2 (count (requests))) "the same results again change nothing")
|
||||
(is (= 3 (count (:messages (chat))))))
|
||||
|
||||
(deftest chat-failure-after-tools-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(asks! (call "a" "ping" "{}"))
|
||||
(testing "the LLM can't be reached with the results: they stay, and the error is shown"
|
||||
(ran! ["a" "ping" "pong" false])
|
||||
(answer! 502 {:error "the LLM server can't be reached"})
|
||||
(is (= ["user" "assistant" "tool"] (map :role (:messages (chat)))) "no message goes back in the input")
|
||||
(is (= {:input "" :status :idle :error "the LLM server can't be reached"}
|
||||
(select-keys (chat) [:input :status :error]))))
|
||||
(testing "the conversation goes on from there"
|
||||
(say! "hello?")
|
||||
(is (= ["user" "assistant" "tool" "user"] (map :role (get-in (last-request) [:body :messages]))))))
|
||||
|
||||
(deftest chat-failure-with-calls-coming-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(event! {:tool-calls [(call "a" "ping" "{}")]})
|
||||
(event! {:error "the connection was lost"})
|
||||
(testing "calls that never got to be made are forgotten, like any reply that didn't come"
|
||||
(is (= {:messages [] :input "hi" :status :idle :error "the connection was lost" :pending-calls nil}
|
||||
(select-keys (chat) [:messages :input :status :error :pending-calls])))
|
||||
(is (= [] (tool-calls-asked)))))
|
||||
|
||||
(deftest chat-sends-no-orphaned-result-test
|
||||
(logged-in! [])
|
||||
;; The oldest message is the one that asked for the call whose result comes next, and it is what
|
||||
;; falls out of the 40 that are sent.
|
||||
(swap! rf-db/app-db assoc-in [:chat :messages]
|
||||
(into [{:role "assistant" :content "" :tool-calls [(call "old" "ping" "{}")]}
|
||||
{:role "tool" :tool-call-id "old" :name "ping" :content "pong" :error? false}]
|
||||
(for [i (range 38)] {:role (if (even? i) "user" "assistant") :content (str i)})))
|
||||
(say! "latest")
|
||||
(let [sent (get-in (last-request) [:body :messages])]
|
||||
(is (= "user" (:role (first sent))) "a result the LLM can't match to a call would be refused")
|
||||
(is (= "0" (:content (first sent))))
|
||||
(is (= "latest" (:content (last sent))))))
|
||||
|
||||
(deftest call-tools-effect-page-test
|
||||
;; The real effect: a tool is called only on a page that offers it.
|
||||
(let [call-tools-fx (tu/real-effect ::events/call-tools)
|
||||
answer (atom nil)]
|
||||
(rf/reg-event-fx ::ran (fn [_ [_ results]] (@answer results) {}))
|
||||
(model-context/register!
|
||||
[{:name "games-only" :pages #{:games} :description "d" :input-schema add-schema :handler (fn [_] "played")}
|
||||
{:name "anywhere" :description "d" :input-schema add-schema :handler (fn [_] "ok")}])
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(js/Promise. (fn [resolve]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:page :todos
|
||||
:calls [(call "1" "games-only" "{}") (call "2" "anywhere" "{}")]
|
||||
:on-results [::ran]})))
|
||||
(fn [results]
|
||||
(is (= [["tool not available on this page: games-only (it is offered on the games page)" true]
|
||||
["ok" false]]
|
||||
(map (juxt :content (comp boolean :error?)) results))))
|
||||
#(js/Promise. (fn [resolve]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:page :games :calls [(call "1" "games-only" "{}")] :on-results [::ran]})))
|
||||
(fn [results] (is (= ["played"] (map :content results)))))
|
||||
done))))
|
||||
|
||||
(deftest call-tools-effect-test
|
||||
;; The real effect, on real tools; the results are dispatched to ::ran.
|
||||
(let [call-tools-fx (tu/real-effect ::events/call-tools)
|
||||
order (atom [])
|
||||
answer (atom nil)]
|
||||
(rf/reg-event-fx ::ran (fn [_ [_ results]] (@answer results) {}))
|
||||
(model-context/register!
|
||||
[{:name "slow" :description "d" :input-schema add-schema
|
||||
:handler (fn [_] (js/Promise. (fn [resolve] (js/setTimeout #(do (swap! order conj :slow) (resolve "slow done")) 20))))}
|
||||
{:name "fast" :description "d" :input-schema add-schema
|
||||
:handler (fn [args] (swap! order conj :fast) (str "fast " (pr-str args)))}
|
||||
{:name "huge" :description "d" :input-schema add-schema :handler (fn [_] (apply str (repeat 9000 "x")))}
|
||||
{:name "blank" :description "d" :input-schema add-schema :handler (fn [_] " ")}
|
||||
{:name "fails" :description "d" :input-schema add-schema :handler (fn [_] (throw (js/Error. "it broke")))}])
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(js/Promise. (fn [resolve]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:calls [(call "1" "slow" "{}")
|
||||
(call "2" "fast" "{\"x\":1}")
|
||||
(call "3" "huge" "{}")
|
||||
(call "4" "blank" "")
|
||||
(call "5" "fails" "{}")
|
||||
(call "6" "nope" "{}")
|
||||
(call "7" "fast" "oops")]
|
||||
:on-results [::ran]})))
|
||||
(fn [results]
|
||||
(testing "one after the other, in order: the tools work on the same page"
|
||||
(is (= [:slow :fast] @order)))
|
||||
(testing "a result for each call, whatever became of it"
|
||||
(is (= ["1" "2" "3" "4" "5" "6" "7"] (map :id results)))
|
||||
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast"] (map :name results)))
|
||||
(is (= ["slow done" "fast {:x 1}"] (map :content (take 2 results)))))
|
||||
(testing "a result is never empty, and never longer than the server takes"
|
||||
(is (= "(no output)" (:content (nth results 3))))
|
||||
(is (= 8000 (count (:content (nth results 2)))))
|
||||
(is (= "xxx … (truncated)" (subs (:content (nth results 2)) 7983))))
|
||||
(testing "failures are results for the LLM to read"
|
||||
(is (= [false false false false true true true] (map (comp boolean :error?) results)))
|
||||
(is (= ["it broke" "unknown tool: nope" "invalid arguments: they must be a JSON object"]
|
||||
(map :content (drop 4 results))))))
|
||||
#(js/Promise. (fn [resolve]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:calls [] :on-results [::ran]})))
|
||||
(fn [results] (is (= [] results) "no calls, no results")))
|
||||
done))))
|
||||
|
||||
;; --- MCP setup ---
|
||||
|
||||
(deftest copy-mcp-command-test
|
||||
|
||||
@@ -0,0 +1,132 @@
|
||||
(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 {:done true})) 1)
|
||||
(fn [_]
|
||||
(is (= ["/api/chat" {:method "POST"
|
||||
:headers {:Content-Type "application/edn"}
|
||||
:body "{:x 1}"}]
|
||||
@asked))))
|
||||
done))))
|
||||
|
||||
(deftest events-test
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(stream! (streaming (atom nil) (sse {:thinking "hm"} {:content "Hel"}) (sse {:content "lo"} {:done true})) 4)
|
||||
(fn [got]
|
||||
(is (= [[:event {:thinking "hm"}] [:event {:content "Hel"}] [:event {:content "lo"}] [:event {:done true}]]
|
||||
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 {:content "héllo 👋 世界"} {:done true})
|
||||
expected [[:event {:content "héllo 👋 世界"}] [:event {:done true}]]]
|
||||
(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 {:content "Hi"})) 2)
|
||||
(fn [got]
|
||||
(is (= [[:event {:content "Hi"}] [:event {:error "the connection was lost"}]] got))))
|
||||
done)))
|
||||
(testing "a read that fails in the middle of the stream"
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(stream! (streaming (atom nil) (sse {:content "Hi"}) :fail (sse {:content "never"})) 2)
|
||||
(fn [got]
|
||||
(is (= [[:event {:content "Hi"}] [:event {:error "the connection was lost"}]] got))))
|
||||
done)))
|
||||
(testing "a stream that ended with an error of its own says so once"
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(stream! (streaming (atom nil) (sse {:content "Hi"} {:error "the LLM server took too long to answer"})) 2)
|
||||
(fn [got]
|
||||
(is (= [[:event {:content "Hi"}] [:event {:error "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,146 @@
|
||||
(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 :games))))
|
||||
(testing "what the LLM is told is MCP's tools/list, in the order of registration, without the handlers"
|
||||
(model-context/register! [(tool "b" identity) (tool "a" identity)])
|
||||
(is (= [{:name "b" :description "b tool" :inputSchema schema}
|
||||
{:name "a" :description "a tool" :inputSchema schema}]
|
||||
(model-context/definitions :games))))
|
||||
(testing "a tool without a description has none"
|
||||
(model-context/clear!)
|
||||
(model-context/register! [(tool "a" identity :description nil)])
|
||||
(is (= [{:name "a" :inputSchema schema}] (model-context/definitions :games)))))
|
||||
|
||||
(deftest register-test
|
||||
(testing "registering a name again replaces the tool, so it is safe on hot reload"
|
||||
(model-context/register! [(tool "a" identity) (tool "b" identity)])
|
||||
(model-context/register! [(tool "a" identity :description "new") (tool "b" identity)])
|
||||
(is (= [["a" "new"] ["b" "b tool"]] (map (juxt :name :description) (model-context/definitions :games)))))
|
||||
(testing "tools of other names stay"
|
||||
(model-context/register! [(tool "c" identity)])
|
||||
(is (= ["a" "b" "c"] (map :name (model-context/definitions :games)))))
|
||||
(testing "clear! takes them all"
|
||||
(model-context/clear!)
|
||||
(is (= [] (model-context/definitions :games)))))
|
||||
|
||||
(deftest pages-test
|
||||
(model-context/register! [(tool "everywhere" identity)
|
||||
(tool "games-only" identity :pages #{:games})
|
||||
(tool "todos-only" identity :pages #{:todos})
|
||||
(tool "both" identity :pages #{:games :todos})])
|
||||
(testing "a tool without pages is offered on every page, the others only on theirs"
|
||||
(is (= ["everywhere" "games-only" "both"] (map :name (model-context/definitions :games))))
|
||||
(is (= ["everywhere" "todos-only" "both"] (map :name (model-context/definitions :todos))))
|
||||
(is (= ["everywhere"] (map :name (model-context/definitions :ai-setup)))))
|
||||
(testing "the pages are not part of what the LLM is told"
|
||||
(is (= #{:name :description :inputSchema} (set (mapcat keys (model-context/definitions :games))))))
|
||||
(testing "a page that is not known, or none, is offered the tools of no page"
|
||||
(is (= ["everywhere"] (map :name (model-context/definitions nil)))))
|
||||
(testing "registering a tool again replaces its pages too"
|
||||
(model-context/register! [(tool "games-only" identity :pages #{:todos})])
|
||||
(is (= ["everywhere" "both"] (map :name (model-context/definitions :games))))))
|
||||
|
||||
(defn- called
|
||||
"A promise of the result of calling `tool-name` on the JSON text `arguments`."
|
||||
[tool-name arguments]
|
||||
(model-context/call! :games tool-name arguments))
|
||||
|
||||
(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 "games-only" (fn [_] (swap! ran conj :games-only) "played") :pages #{:games})
|
||||
(tool "everywhere" (fn [_] (swap! ran conj :everywhere) "ran"))])
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(model-context/call! :games "games-only" "{}")
|
||||
(fn [r] (is (= {:text "played" :error? false} r) "on its page, a tool is called"))
|
||||
#(model-context/call! :todos "everywhere" "{}")
|
||||
(fn [r] (is (= {:text "ran" :error? false} r) "a tool of no page is called on any"))
|
||||
#(model-context/call! :todos "games-only" "{}")
|
||||
(fn [r]
|
||||
(testing "a tool of another page is refused, and the LLM is told where it is offered"
|
||||
(is (= {:text "tool not available on this page: games-only (it is offered on the games page)"
|
||||
:error? true}
|
||||
r))))
|
||||
(fn [_] (is (= [:games-only :everywhere] @ran) "and never run")))
|
||||
done))))
|
||||
|
||||
(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,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")))))
|
||||
@@ -22,12 +22,30 @@
|
||||
;; --- A fake server ---
|
||||
|
||||
(def server
|
||||
"What the fake server holds: {:user nil-or-{:login ..}, :todos [..], :next-id n, :add-error msg}."
|
||||
"What the fake server holds: {:user nil-or-{:login ..}, :todos [..], :next-id n, :add-error msg,
|
||||
:chat-error msg, :chats [the conversations it was sent], :chat-requests [the whole requests],
|
||||
:chat-scripts [..], :chat-script [..], :resume fn}. Its LLM says \"echo: \" and the last message,
|
||||
streaming it in pieces. `:chat-script`, if set, is what it streams instead: events (maps, as the
|
||||
real server sends them) and :pause, where the stream stops until the test calls the `:resume` fn
|
||||
the server then holds. `:chat-scripts` are scripts for the next requests, one each, first
|
||||
come first served (a conversation that goes back and forth, as when the LLM uses tools)."
|
||||
(atom nil))
|
||||
|
||||
(defn- respond [status body]
|
||||
{:status status :body (pr-str body)})
|
||||
|
||||
(defn- respond-stream
|
||||
"A 200 whose body is the server-sent events of `script` (events and :pause)."
|
||||
[script]
|
||||
{:status 200 :script script})
|
||||
|
||||
(defn- next-chat-script!
|
||||
"The next of the server's `:chat-scripts`, which it is then rid of, or nil."
|
||||
[]
|
||||
(when-let [script (first (:chat-scripts @server))]
|
||||
(swap! server update :chat-scripts subvec 1)
|
||||
script))
|
||||
|
||||
(defn- route [method uri body]
|
||||
(let [{:keys [user todos]} @server
|
||||
todo-id (some->> (re-find #"^/api/todos/(\d+)$" uri) second js/parseInt)]
|
||||
@@ -41,6 +59,17 @@
|
||||
(respond 400 {:error error :details {:x ["is wrong"]}})
|
||||
(respond 200 {:result (+ (js/parseFloat x) (js/parseFloat y))})))
|
||||
(not user) (respond 401 {:error "not logged in"})
|
||||
(and (= "POST" method) (= "/api/chat" uri))
|
||||
(if-let [error (:chat-error @server)]
|
||||
(respond 502 {:error error})
|
||||
(do (swap! server update :chats (fnil conj []) (:messages body))
|
||||
(swap! server update :chat-requests (fnil conj []) body)
|
||||
(respond-stream (or (next-chat-script!)
|
||||
(:chat-script @server)
|
||||
[{:thinking "Reading the message."}
|
||||
{:content "echo: "}
|
||||
{:content (:content (last (:messages body)))}
|
||||
{:done true}]))))
|
||||
(and (= "GET" method) (= "/api/todos" uri)) (respond 200 {:todos todos})
|
||||
(and (= "POST" method) (= "/api/todos" uri))
|
||||
(if (seq (.trim (:title body)))
|
||||
@@ -60,11 +89,45 @@
|
||||
(respond 200 {:deleted true}))
|
||||
:else (respond 404 {:error "not found"}))))
|
||||
|
||||
(def ^:private piece-size
|
||||
"How many bytes of a stream the fake server delivers at a time: few, so events are cut anywhere,
|
||||
even in the middle of a character, as the network may."
|
||||
7)
|
||||
|
||||
(defn- script-items
|
||||
"The script's events as the pieces of bytes that arrive, and :pause where the stream waits."
|
||||
[script]
|
||||
(mapcat (fn [step]
|
||||
(if (= :pause step)
|
||||
[:pause]
|
||||
(let [bytes (.encode (js/TextEncoder.)
|
||||
(str "data: " (js/JSON.stringify (clj->js step)) "\n\n"))]
|
||||
(for [i (range 0 (.-length bytes) piece-size)]
|
||||
(.subarray bytes i (min (.-length bytes) (+ i piece-size)))))))
|
||||
script))
|
||||
|
||||
(defn- stream-reader
|
||||
"What `response.body.getReader()` gives for a stream of `script`: `read` resolves with a piece
|
||||
of bytes at a time, then with done. At a :pause it waits for the fn the server holds as :resume."
|
||||
[script]
|
||||
(let [items (atom (script-items script))]
|
||||
(letfn [(read []
|
||||
(let [item (first @items)]
|
||||
(swap! items rest)
|
||||
(cond
|
||||
(nil? item) (js/Promise.resolve #js {:done true})
|
||||
(= :pause item) (js/Promise. (fn [resolve]
|
||||
(swap! server assoc :resume #(resolve (read)))))
|
||||
:else (js/Promise.resolve #js {:done false :value item}))))]
|
||||
#js {:read read})))
|
||||
|
||||
(defn fake-fetch [uri opts]
|
||||
(let [opts (js->clj opts :keywordize-keys true)
|
||||
{:keys [status body]} (route (:method opts) uri (some-> (:body opts) reader/read-string))]
|
||||
{:keys [status body script]} (route (:method opts) uri (some-> (:body opts) reader/read-string))]
|
||||
(js/Promise.resolve
|
||||
#js {:ok (< status 300) :status status :text (fn [] (js/Promise.resolve body))})))
|
||||
#js {:ok (< status 300) :status status
|
||||
:text (fn [] (js/Promise.resolve body))
|
||||
:body #js {:getReader (fn [] (stream-reader script))}})))
|
||||
|
||||
(def ^:private real-fetch (.-fetch js/globalThis))
|
||||
|
||||
|
||||
@@ -7,6 +7,7 @@
|
||||
[re-frame.db :as rf-db]
|
||||
[tbd.ui.db :as db]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.model-context :as model-context]
|
||||
[tbd.ui.pages :as pages]
|
||||
[tbd.ui.test-util :as tu :refer [q q-all text shows steps click! type! submit!]]
|
||||
[tbd.ui.views :as views]
|
||||
@@ -467,3 +468,476 @@
|
||||
(is (= "Log in" (text "section p a")))
|
||||
(is (= "/auth/login" (.getAttribute (q "section p a") "href")))))
|
||||
done)))
|
||||
|
||||
;; --- Chat widget ---
|
||||
|
||||
(defn- panel [] (q "[role=dialog]"))
|
||||
|
||||
(defn- chat-messages
|
||||
"What the conversation shows, message by message."
|
||||
[]
|
||||
(mapv #(.-textContent %) (q-all "[role=log] > div:not([role=status]):not([data-tool])")))
|
||||
|
||||
(defn- chat-tool-lines
|
||||
"The tool calls and results the conversation shows, line by line."
|
||||
[]
|
||||
(mapv #(.-textContent %) (q-all "[role=log] > div[data-tool]")))
|
||||
|
||||
(deftest chat-widget-test
|
||||
;; A green square in the bottom left corner, opposite WebMCP's blue one; it opens the panel.
|
||||
(async done
|
||||
(tu/finish
|
||||
(steps
|
||||
#(log-in-page! [])
|
||||
(fn []
|
||||
(let [square (q "button[aria-label=Chat]")
|
||||
style (.-style square)]
|
||||
(is (= "fixed" (.. square -parentElement -style -position)))
|
||||
(is (= ["20px" "20px"] [(.. square -parentElement -style -left) (.. square -parentElement -style -bottom)])
|
||||
"bottom left")
|
||||
(is (= "rgb(40, 167, 69)" (.-backgroundColor style)) "green")
|
||||
(is (= "false" (.getAttribute square "aria-expanded")))
|
||||
(is (nil? (panel)) "the panel starts closed")
|
||||
(click! square)))
|
||||
#(tu/eventually panel)
|
||||
(fn [_]
|
||||
(is (= "true" (.getAttribute (q "button[aria-label=Chat]") "aria-expanded")))
|
||||
(is (= "Ask me anything." (text "[role=log] p")))
|
||||
(is (nil? (q "[role=alert]")))
|
||||
(click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (nil? (panel))))
|
||||
(fn [_]
|
||||
(is true "the square closes it again")
|
||||
(click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually panel)
|
||||
(fn [_]
|
||||
(click! (q "button[aria-label=\"Close chat\"]")))
|
||||
#(tu/eventually (fn [] (nil? (panel)))))
|
||||
done)))
|
||||
|
||||
(deftest chat-conversation-test
|
||||
(async done
|
||||
(tu/finish
|
||||
(steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (q "input[name=message]")))
|
||||
(fn [input]
|
||||
(is (true? (.-disabled (q "[role=dialog] button[type=submit]"))) "nothing to send yet")
|
||||
(type! input "hello")
|
||||
(tu/eventually (fn [] (false? (.-disabled (q "[role=dialog] button[type=submit]"))))))
|
||||
(fn [_]
|
||||
(submit! (q "[role=dialog] form"))
|
||||
(tu/eventually (fn [] (= ["hello" "echo: hello"] (chat-messages)))))
|
||||
(fn [_]
|
||||
(is (= "" (.-value (q "input[name=message]"))) "the input is emptied when sent")
|
||||
(is (nil? (q "[role=status]")) "no longer thinking")
|
||||
(is (= ["Clear" "×"] (mapv #(.-textContent %) (q-all "[role=dialog] > div:first-child button"))))
|
||||
(type! (q "input[name=message]") "again")
|
||||
(tu/eventually (fn [] (= "again" (.-value (q "input[name=message]"))))))
|
||||
(fn [_]
|
||||
(submit! (q "[role=dialog] form"))
|
||||
(tu/eventually (fn [] (= 4 (count (chat-messages))))))
|
||||
(fn [_]
|
||||
(is (= [[{:role "user" :content "hello"}]
|
||||
[{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "echo: hello"}
|
||||
{:role "user" :content "again"}]]
|
||||
(:chats @tu/server))
|
||||
"each message carries the conversation so far")
|
||||
(click! (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button")))))
|
||||
#(tu/eventually (fn [] (= "Ask me anything." (text "[role=log] p"))))
|
||||
(fn [_]
|
||||
(is (empty? (chat-messages)) "cleared")))
|
||||
done)))
|
||||
|
||||
(deftest chat-thinking-test
|
||||
;; While the reply is on its way the page says so, and the input can't take another message.
|
||||
(async done
|
||||
(let [release (atom nil)
|
||||
fake-fetch (aget js/globalThis "fetch")]
|
||||
(aset js/globalThis "fetch"
|
||||
(fn [uri opts]
|
||||
(if (= "/api/chat" uri)
|
||||
(js/Promise. (fn [resolve] (reset! release #(resolve (fake-fetch uri opts)))))
|
||||
(fake-fetch uri opts))))
|
||||
(tu/finish
|
||||
(steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (q "input[name=message]")))
|
||||
(fn [input] (type! input "hello") (tu/eventually #(= "hello" (.-value input))))
|
||||
(fn [_] (submit! (q "[role=dialog] form")))
|
||||
#(tu/eventually (fn [] (q "[role=status]")))
|
||||
(fn [_]
|
||||
(is (= "Thinking…" (text "[role=status]")))
|
||||
(is (= ["hello"] (chat-messages)))
|
||||
(is (true? (.-readOnly (q "input[name=message]"))))
|
||||
(is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
|
||||
(is (nil? (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button"))))
|
||||
"can't start over mid-reply")
|
||||
(@release))
|
||||
#(tu/eventually (fn [] (nil? (q "[role=status]"))))
|
||||
(fn [_]
|
||||
(is (= ["hello" "echo: hello"] (chat-messages)))
|
||||
(is (false? (.-readOnly (q "input[name=message]"))))))
|
||||
done))))
|
||||
|
||||
(defn- send-chat!
|
||||
"Types `text` into the chat's input and sends it; a promise, which resolves once it was sent."
|
||||
[text]
|
||||
(tu/steps
|
||||
(fn [] (tu/eventually (fn [] (q "input[name=message]"))))
|
||||
(fn [input] (type! input text) (tu/eventually #(= text (.-value input))))
|
||||
(fn [_] (submit! (q "[role=dialog] form")))))
|
||||
|
||||
(defn- resume-stream!
|
||||
"Lets the fake server's stream go on from its pause (see tu/server)."
|
||||
[]
|
||||
(let [resume (:resume @tu/server)]
|
||||
(swap! tu/server dissoc :resume)
|
||||
(resume)))
|
||||
|
||||
(defn- panel-text
|
||||
"Everything the chat panel shows, as text."
|
||||
[]
|
||||
(.-textContent (panel)))
|
||||
|
||||
(deftest chat-streaming-test
|
||||
;; The reply shows as it arrives: "Thinking…" until the model's first word (however long it
|
||||
;; reasons, which is never shown), then the reply growing piece by piece, and only at its end can
|
||||
;; another message be sent.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [:pause
|
||||
{:thinking "Let me "} {:thinking "think."} :pause
|
||||
{:content "Hel"} {:content "lo"} :pause
|
||||
{:content ", world"} {:done true}])
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (q "[role=status]"))))
|
||||
(fn [_]
|
||||
(is (= "Thinking…" (text "[role=status]")))
|
||||
(is (= ["hi"] (chat-messages)) "nothing of the reply yet")
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (:resume @tu/server)))
|
||||
(fn [_]
|
||||
(is (= "Thinking…" (text "[role=status]")) "still thinking while the model reasons")
|
||||
(is (not (str/includes? (panel-text) "Let me think.")) "and what it reasons is not shown")
|
||||
(is (= ["hi"] (chat-messages)) "it hasn't said anything")
|
||||
(is (true? (.-readOnly (q "input[name=message]"))) "and it isn't over")
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "Hello"] (chat-messages)))))
|
||||
(fn [_]
|
||||
(is (nil? (q "[role=status]")) "the model has begun to answer")
|
||||
(is (true? (.-readOnly (q "input[name=message]"))) "but it isn't over")
|
||||
(is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (= ["hi" "Hello, world"] (chat-messages))))
|
||||
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]")))))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "Let me think.")) "the reasoning is not shown after it either")
|
||||
(is (nil? (q "[role=status]")))
|
||||
(is (nil? (q "[role=dialog] [role=alert]")))))
|
||||
done)))
|
||||
|
||||
(deftest chat-reasoning-is-never-shown-test
|
||||
;; Neither while it comes nor in the finished conversation, in any element of the panel.
|
||||
(async done
|
||||
(let [thought "secret reasoning about the answer"]
|
||||
(swap! tu/server assoc :chat-script [{:thinking thought} {:content "Done."} {:done true}])
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (= ["hi" "Done."] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "secret")))))
|
||||
done))))
|
||||
|
||||
(defn- pointer!
|
||||
"Fires a pointer event of `type` at `target`, at (`x`, `y`)."
|
||||
[target type x y]
|
||||
(.dispatchEvent target (js/window.MouseEvent. type #js {:bubbles true :clientX x :clientY y :button 0})))
|
||||
|
||||
(defn- chat-size [] (:size (:chat @rf-db/app-db)))
|
||||
|
||||
(defn- drag-to!
|
||||
"Moves the pointer to (`x`, `y`), and waits for the panel to have `size` by it."
|
||||
[x y size]
|
||||
(pointer! js/window "pointermove" x y)
|
||||
(tu/eventually (fn [] (= size (chat-size)))))
|
||||
|
||||
(deftest chat-resize-test
|
||||
;; The panel is stuck to the bottom left corner, so dragging its top right corner out is what
|
||||
;; makes it bigger: right for wider, up for higher. Every drag is from the size it began with.
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually panel)
|
||||
(fn [_]
|
||||
(is (= "320px" (.. (panel) -style -width)))
|
||||
(is (= "256px" (.. (q "[role=log]") -style -height)))
|
||||
(is (= "Resize chat" (.getAttribute (q "[role=separator]") "aria-label")))
|
||||
(pointer! (q "[role=separator]") "pointerdown" 300 300))
|
||||
#(drag-to! 350 260 {:width 370 :height 296})
|
||||
#(tu/eventually (fn [] (= ["370px" "296px"] [(.. (panel) -style -width) (.. (q "[role=log]") -style -height)])))
|
||||
(fn [_] (is true "right 50, up 40"))
|
||||
#(drag-to! 280 380 {:width 300 :height 176})
|
||||
#(drag-to! -900 900 {:width 260 :height 96})
|
||||
(fn [_] (is true "not smaller than is usable"))
|
||||
#(drag-to! 9000 -9000 {:width (- js/window.innerWidth 40) :height (- js/window.innerHeight 220)})
|
||||
(fn [_] (is true "not bigger than the window"))
|
||||
#(drag-to! 400 300 {:width 420 :height 256})
|
||||
(fn [_]
|
||||
(pointer! js/window "pointerup" 400 300)
|
||||
(pointer! js/window "pointermove" 900 100)
|
||||
(js/Promise. (fn [resolve] (js/setTimeout resolve 20))))
|
||||
(fn [_]
|
||||
(is (= {:width 420 :height 256} (chat-size)) "once let go, the pointer no longer resizes")
|
||||
(click! (q "button[aria-label=\"Close chat\"]")))
|
||||
#(tu/eventually (fn [] (nil? (panel))))
|
||||
(fn [_] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually panel)
|
||||
(fn [_]
|
||||
(is (= "420px" (.. (panel) -style -width)) "the size is kept while it is closed")))
|
||||
done)))
|
||||
|
||||
(defn- fake-scroll!
|
||||
"jsdom doesn't lay anything out: give `el` the sizes of a conversation of 1000px in a window of
|
||||
100px, and a scroll position that stays where it is put."
|
||||
[el]
|
||||
(let [top (atom 0)]
|
||||
(js/Object.defineProperty el "scrollHeight" #js {:get (fn [] 1000)})
|
||||
(js/Object.defineProperty el "clientHeight" #js {:get (fn [] 100)})
|
||||
(js/Object.defineProperty el "scrollTop" #js {:get (fn [] @top) :set (fn [v] (reset! top v))})
|
||||
top))
|
||||
|
||||
(deftest chat-scrollback-test
|
||||
;; The conversation follows its end while it is scrolled to it, but scrolling up to read back
|
||||
;; is left alone, even as the reply keeps coming; sending a message goes back to the end.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [{:content "one"} :pause
|
||||
{:content " two"} :pause
|
||||
{:content " three"} {:done true}])
|
||||
(let [top (atom nil)
|
||||
resume! (fn []
|
||||
(let [resume (:resume @tu/server)]
|
||||
(swap! tu/server dissoc :resume)
|
||||
(resume)))]
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (q "[role=log]")))
|
||||
(fn [log] (reset! top (fake-scroll! log)))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "one"] (chat-messages)))))
|
||||
(fn [_]
|
||||
(is (= 1000 @@top) "at the end, it follows the end")
|
||||
(reset! @top 200)
|
||||
(.dispatchEvent (q "[role=log]") (js/window.Event. "scroll"))
|
||||
(resume!))
|
||||
#(tu/eventually (fn [] (= ["hi" "one two"] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (= 200 @@top) "scrolled up, the reply coming in doesn't pull it down")
|
||||
(reset! @top 890)
|
||||
(.dispatchEvent (q "[role=log]") (js/window.Event. "scroll"))
|
||||
(resume!))
|
||||
#(tu/eventually (fn [] (= ["hi" "one two three"] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (= 1000 @@top) "back near the end, it follows again")
|
||||
(reset! @top 200)
|
||||
(.dispatchEvent (q "[role=log]") (js/window.Event. "scroll")))
|
||||
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]")))))
|
||||
#(send-chat! "again")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= 1000 @@top))))
|
||||
(fn [_]
|
||||
(is (= 1000 @@top) "sending a message goes back to the end, wherever it was")
|
||||
(resume!))
|
||||
#(tu/eventually (fn [] (:resume @tu/server)))
|
||||
(fn [_] (resume!)))
|
||||
done))))
|
||||
|
||||
(deftest chat-tools-test
|
||||
;; The LLM asks for the page's own tools: the page calls them, so it shows on the page, and the
|
||||
;; results go back to the LLM for its answer.
|
||||
(async done
|
||||
(model-context/register! webmcp/tools)
|
||||
(swap! tu/server assoc :chat-scripts
|
||||
[[{:content "I'll add them."}
|
||||
{:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":2,\"y\":3}"}]}
|
||||
{:done true}]
|
||||
[{:content "2 + 3 is 5."} {:done true}]])
|
||||
(tu/finish
|
||||
(-> (tu/steps
|
||||
#(log-in-page! [])
|
||||
;; The calculator's tools are offered on the games page.
|
||||
(fn [] (rf/dispatch-sync [::events/navigate :games]))
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "what is 2 + 3? use the calculator")
|
||||
#(tu/eventually (fn [] (= ["what is 2 + 3? use the calculator" "I'll add them." "2 + 3 is 5."]
|
||||
(chat-messages))))
|
||||
(fn [_]
|
||||
(testing "the LLM was told about the tools of the page it was on (the games), not all of them"
|
||||
(is (= (set (map :name (filter #(contains? (or (:pages %) #{:games}) :games) webmcp/tools)))
|
||||
(set (map :name (:tools (first (:chat-requests @tu/server))))))))
|
||||
(testing "the page made the call, as a user would: the calculator holds what was typed and its sum"
|
||||
(is (= {:x "2" :y "3" :result {:status :ok :x "2" :y "3" :sum 5}}
|
||||
(:calc @rf-db/app-db))))
|
||||
(testing "the call and its result show in the conversation, between what was said"
|
||||
(is (= ["Calling add {\"x\":2,\"y\":3}…" "add → {\"x\":2,\"y\":3,\"sum\":5}"]
|
||||
(chat-tool-lines)))
|
||||
(testing "the lines are shown whole: wrapped, not cut off"
|
||||
(doseq [line (q-all "[data-tool]")]
|
||||
(is (= "pre-wrap" (.. line -style -whiteSpace)))
|
||||
(is (= "" (.. line -style -textOverflow)))
|
||||
(is (not= "hidden" (.. line -style -overflow)))
|
||||
(is (nil? (.getAttribute line "title")) "no tooltip: there is nothing hidden")))
|
||||
(is (= ["user" "assistant" "tool" "assistant"] (map :role (:messages (:chat @rf-db/app-db))))))
|
||||
(testing "the second request took the result to the LLM"
|
||||
(is (= [{:role "user" :content "what is 2 + 3? use the calculator"}
|
||||
{:role "assistant" :content "I'll add them."
|
||||
:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":2,\"y\":3}"}]}
|
||||
{:role "tool" :tool-call-id "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
|
||||
(:messages (second (:chat-requests @tu/server))))))
|
||||
(testing "and it is over: the panel takes messages again"
|
||||
(is (false? (.-readOnly (q "input[name=message]")))))))
|
||||
(.finally model-context/clear!))
|
||||
done)))
|
||||
|
||||
(deftest chat-tool-error-test
|
||||
;; A tool that can't do what it was asked is an error the LLM reads, not the end of the chat.
|
||||
(async done
|
||||
(model-context/register! webmcp/tools)
|
||||
(swap! tu/server assoc :chat-scripts
|
||||
[[{:tool-calls [{:id "c1" :name "add" :arguments "{\"x\":\"two\",\"y\":3}"}
|
||||
{:id "c2" :name "made_up" :arguments "{}"}]}
|
||||
{:done true}]
|
||||
[{:content "Sorry, that didn't work."} {:done true}]])
|
||||
(tu/finish
|
||||
(-> (tu/steps
|
||||
#(log-in-page! [])
|
||||
;; The calculator's tools are offered on the games page.
|
||||
(fn [] (rf/dispatch-sync [::events/navigate :games]))
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "add two and three")
|
||||
#(tu/eventually (fn [] (= ["add two and three" "Sorry, that didn't work."] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (= ["Calling add {\"x\":\"two\",\"y\":3}…" "Calling made_up {}…"
|
||||
"add failed: invalid arguments: x and y must be numbers"
|
||||
"made_up failed: unknown tool: made_up"]
|
||||
(chat-tool-lines)))
|
||||
(is (= "crimson" (.. (last (q-all "[role=log] > div[data-tool]")) -style -color)) "failures stand out")
|
||||
(is (= [true true] (map :error? (filter #(= "tool" (:role %)) (:messages (:chat @rf-db/app-db))))))
|
||||
(is (nil? (q "[role=dialog] [role=alert]")) "it isn't an error of the chat's")
|
||||
(is (= {:x "" :y "" :result {:status :idle}} (:calc @rf-db/app-db)) "nothing was done")))
|
||||
(.finally model-context/clear!))
|
||||
done)))
|
||||
|
||||
(deftest chat-stream-failure-test
|
||||
;; The stream breaks in the middle of the reply: what came stays, with the error under it.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [{:thinking "hm"} {:content "Hel"}
|
||||
{:error "the LLM server took too long to answer"}])
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (q "[role=dialog] [role=alert]")))
|
||||
(fn [_]
|
||||
(is (= "the LLM server took too long to answer" (text "[role=dialog] [role=alert]")))
|
||||
(is (= ["hi" "Hel"] (chat-messages)))
|
||||
(is (nil? (q "[role=status]")))
|
||||
(is (= "" (.-value (q "input[name=message]"))))
|
||||
(is (false? (.-readOnly (q "input[name=message]"))) "another message can be sent")))
|
||||
done)))
|
||||
|
||||
(deftest chat-stream-cut-test
|
||||
;; The connection drops with no word from the server: the page says so, rather than wait forever.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [{:content "Hel"}])
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (q "[role=dialog] [role=alert]")))
|
||||
(fn [_]
|
||||
(is (= "the connection was lost" (text "[role=dialog] [role=alert]")))
|
||||
(is (= ["hi" "Hel"] (chat-messages)))
|
||||
(is (nil? (q "[role=status]")) "no longer thinking")))
|
||||
done)))
|
||||
|
||||
(deftest chat-text-survives-the-stream-test
|
||||
;; The fake server sends its bytes in pieces of a few, so this cuts the text mid-character.
|
||||
(async done
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(send-chat! "héllo 👋 世界")
|
||||
#(tu/eventually (fn [] (= 2 (count (chat-messages)))))
|
||||
(fn [_]
|
||||
(is (= ["héllo 👋 世界" "echo: héllo 👋 世界"] (chat-messages)))))
|
||||
done)))
|
||||
|
||||
(deftest chat-error-test
|
||||
(async done
|
||||
(tu/finish
|
||||
(steps
|
||||
#(log-in-page! [])
|
||||
(fn []
|
||||
(swap! tu/server assoc :chat-error "the LLM server can't be reached")
|
||||
(click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (q "input[name=message]")))
|
||||
(fn [input] (type! input "hello") (tu/eventually #(= "hello" (.-value input))))
|
||||
(fn [_] (submit! (q "[role=dialog] form")))
|
||||
#(tu/eventually (fn [] (q "[role=dialog] [role=alert]")))
|
||||
(fn [_]
|
||||
(is (= "the LLM server can't be reached" (text "[role=dialog] [role=alert]")))
|
||||
(is (empty? (chat-messages)))
|
||||
(is (= "hello" (.-value (q "input[name=message]"))) "the message is back in the input, to send again")
|
||||
(swap! tu/server dissoc :chat-error)
|
||||
(submit! (q "[role=dialog] form")))
|
||||
#(tu/eventually (fn [] (= ["hello" "echo: hello"] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (nil? (q "[role=dialog] [role=alert]")) "the error goes away")))
|
||||
done)))
|
||||
|
||||
(deftest chat-needs-login-test
|
||||
(async done
|
||||
(tu/finish
|
||||
(steps
|
||||
#(open-page!)
|
||||
#(tu/eventually (fn [] (some #{"Log in"} (nav-links))))
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually panel)
|
||||
(fn [_]
|
||||
(is (= "Log in to chat." (text "[role=dialog] p")))
|
||||
(is (= "/auth/login" (.getAttribute (q "[role=dialog] p a") "href")))
|
||||
(is (nil? (q "input[name=message]")) "no way to type without a login")))
|
||||
done)))
|
||||
|
||||
(deftest chat-forgotten-on-logout-test
|
||||
(async done
|
||||
(tu/finish
|
||||
(steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
#(tu/eventually (fn [] (q "input[name=message]")))
|
||||
(fn [input] (type! input "secret") (tu/eventually #(= "secret" (.-value input))))
|
||||
(fn [_] (submit! (q "[role=dialog] form")))
|
||||
#(tu/eventually (fn [] (= 2 (count (chat-messages)))))
|
||||
(fn [_] (click! (q "main > p:last-child button")))
|
||||
#(tu/eventually (fn [] (= "Log in to chat." (text "[role=dialog] p"))))
|
||||
(fn [_]
|
||||
(is (empty? (chat-messages)))
|
||||
(is (= [] (:messages (:chat @rf-db/app-db))) "and the conversation is gone, not just hidden")))
|
||||
done)))
|
||||
|
||||
@@ -164,7 +164,7 @@
|
||||
(call "get_tic_tac_toe" {})))
|
||||
(.then (fn [_]
|
||||
(is (= :ai-setup (page)) "reading changes nothing")
|
||||
(call "move_tic_tac_toe" {:cell 4})))
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
|
||||
(.then (fn [_]
|
||||
(is (= :games (page)))
|
||||
(rf/dispatch-sync [::events/navigate :ai-setup])
|
||||
@@ -191,6 +191,56 @@
|
||||
(is (= :todos (page)))
|
||||
(done))))))
|
||||
|
||||
(deftest navigate
|
||||
(open-page!)
|
||||
(async done
|
||||
(-> (page-loaded)
|
||||
(.then #(call "navigate" {:page "ai-setup"}))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "{\"page\":\"ai-setup\",\"title\":\"AI setup\"}" :error? false} r))
|
||||
(is (= :ai-setup (page)) "the page is shown, as after a click on its tab")
|
||||
(is (= "#/ai-setup" js/location.hash) "and the URL follows")
|
||||
(call "navigate" {:page "games"})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= :games (page)))
|
||||
(call "navigate" {:page "nowhere"})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r))
|
||||
(is (re-find #"page must be one of games, todos, ai-setup" (:text r)))
|
||||
(call "navigate" {:page "ai-setup"})))
|
||||
(.then (fn [_]
|
||||
(call "navigate" {:page 5})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r) "the page is the name of one")
|
||||
(call "navigate" {})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r))
|
||||
(is (= :ai-setup (page)) "a refused navigation leaves the page where it was")
|
||||
(done))))))
|
||||
|
||||
(deftest navigate-to-a-page-that-needs-a-login
|
||||
(open-page!)
|
||||
(async done
|
||||
(-> (page-loaded)
|
||||
(.then #(call "navigate" {:page "todos"}))
|
||||
(.then (fn [r]
|
||||
(is (:error? r) "the tab isn't there for someone who is not logged in")
|
||||
(is (re-find #"not logged in" (:text r)))
|
||||
(is (= :games (page)))
|
||||
(done))))))
|
||||
|
||||
(deftest navigate-to-the-todos-when-logged-in
|
||||
(tu/log-in!)
|
||||
(open-page!)
|
||||
(async done
|
||||
(-> (page-loaded)
|
||||
(.then #(call "navigate" {:page "todos"}))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "{\"page\":\"todos\",\"title\":\"Todos\"}" :error? false} r))
|
||||
(is (= :todos (page)))
|
||||
(done))))))
|
||||
|
||||
(deftest a-tool-that-fails-leaves-the-page-alone
|
||||
(open-page!)
|
||||
(async done
|
||||
@@ -268,24 +318,32 @@
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
|
||||
(call "move_tic_tac_toe" {:cell 4})))
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
|
||||
(.then (fn [r]
|
||||
;; It pressed the cell, as a user would, and says it is O's turn now.
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
|
||||
(is (= {:board [nil nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "o"}
|
||||
(json (:text r))))
|
||||
(call "move_tic_tac_toe" {:cell 4})))
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "cell 4 is taken" :error? true} r))
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])) "the mark on the taken cell stays")
|
||||
(is (= :o (get-in @rf-db/app-db [:ttt :turn])) "and the refused move does not use up the turn")
|
||||
(call "move_tic_tac_toe" {:cell 0 :player "x"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "it is o's turn, not x's" :error? true} r))
|
||||
(is (:error? r))
|
||||
(is (re-find #"it is o's turn, not x's" (:text r)))
|
||||
(is (nil? (get-in @rf-db/app-db [:ttt :board 0])) "nothing was moved")
|
||||
(call "move_tic_tac_toe" {:cell 9})))
|
||||
(call "move_tic_tac_toe" {:cell 0})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r) "the side is required: no moving for whoever's turn it is")
|
||||
(is (re-find #"player must be" (:text r)))
|
||||
(is (nil? (get-in @rf-db/app-db [:ttt :board 0])) "nothing was moved")
|
||||
(call "move_tic_tac_toe" {:cell 9 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r))
|
||||
(is (re-find #"0 to 8" (:text r)))
|
||||
(call "move_tic_tac_toe" {:cell 1.5})))
|
||||
(call "move_tic_tac_toe" {:cell 1.5 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r))
|
||||
(call "move_tic_tac_toe" {:cell 0 :player "z"})))
|
||||
@@ -302,7 +360,7 @@
|
||||
(is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil]
|
||||
:status "won" :winner "x" :line [3 4 5]}
|
||||
(json (:text r))))
|
||||
(call "move_tic_tac_toe" {:cell 8})))
|
||||
(call "move_tic_tac_toe" {:cell 8 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "the game is over: start a new game" :error? true} r))
|
||||
(call "new_tic_tac_toe_game" {})))
|
||||
|
||||
Reference in New Issue
Block a user