diff options
| -rw-r--r-- | kaakaa/tea.scm | 83 | ||||
| -rw-r--r-- | kaakaa/tools.scm | 12 |
2 files changed, 65 insertions, 30 deletions
diff --git a/kaakaa/tea.scm b/kaakaa/tea.scm index 57526bc..8481dce 100644 --- a/kaakaa/tea.scm +++ b/kaakaa/tea.scm @@ -48,12 +48,19 @@ (define-record-type* (<session> session session?) (lambda (constructor) - (lambda* (cwd #:key cancelling? (messages '()) (pending-tool-calls '())) - (constructor cwd cancelling? messages pending-tool-calls))) + (lambda* (cwd #:key + cancelling? (messages '()) (pending-tool-calls '()) + (allowed-tools '()) (rejected-tools '())) + (constructor cwd cancelling? messages pending-tool-calls + allowed-tools rejected-tools))) (fields (cwd session-cwd lensed) (cancelling? session-cancelling? lensed) (messages session-messages lensed) - (tool-calls session-tool-calls lensed))) + (tool-calls session-tool-calls lensed) + ;; List of tool names that are allowlisted for the session + (allowed-tools session-allowed-tools lensed) + ;; List of tool names that are blocklisted for the session + (rejected-tools session-rejected-tools lensed))) (define-record-type* (<state> state state?) (fields (client-request-id state-client-request-id lensed) @@ -130,6 +137,20 @@ (key-ref session-id) state-sessions)) +(define (state-allowed-tools session-id) + "Return a lens to focus on allowed tools of session with @var{session-id} in +state." + (compose session-allowed-tools + (key-ref session-id) + state-sessions)) + +(define (state-rejected-tools session-id) + "Return a lens to focus on rejected tools of session with @var{session-id} in +state." + (compose session-rejected-tools + (key-ref session-id) + state-sessions)) + (define (state-tool-call tool-call-id session-id) "Return a lens to focus on tool call with @var{tool-call-id} of session with @var{session-id} in state." @@ -405,6 +426,10 @@ and a list of effects. (focus (state-cwd session-id) state) tools + (focus (state-allowed-tools session-id) + state) + (focus (state-rejected-tools session-id) + state) call-json)) (request-id (focus state-agent-request-id state))) (values (-> state @@ -425,30 +450,34 @@ and a list of effects. (let ((tool (focus (key-ref (tool-call-function call)) tools)) (args (alist->plist (tool-call-arguments call)))) - (map acp-message - `(;; Notify client about new tool call. - (("jsonrpc" . "2.0") - ("method" . "session/update") - ("params" - ("sessionId" . ,session-id) - ("update" - ("sessionUpdate" . "tool_call") - ("toolCallId" . ,(tool-call-id call)) - ("title" . ,(apply (tool-title tool) args)) - ("kind" . ,(apply (tool-kind tool) args)) - ("rawInput" . ,(tool-call-arguments call)) - ("status" . "pending")))) - ;; Request permission from the client. - (("jsonrpc" . "2.0") - ("id" . ,request-id) - ("method" . "session/request_permission") - ("params" - ("sessionId" . ,session-id) - ("toolCall" - ("toolCallId" . ,(tool-call-id call))) - ("options" . - ,(vector %tool-allow-once - %tool-reject-once))))))))))) + (list + ;; Notify client about new tool call. + (acp-message `(("jsonrpc" . "2.0") + ("method" . "session/update") + ("params" + ("sessionId" . ,session-id) + ("update" + ("sessionUpdate" . "tool_call") + ("toolCallId" . ,(tool-call-id call)) + ("title" . ,(apply (tool-title tool) args)) + ("kind" . ,(apply (tool-kind tool) args)) + ("rawInput" . ,(tool-call-arguments call)) + ("status" . "pending"))))) + ;; Request permission from the client if necessary. Else, + ;; schedule the tool call. + (if (eq? (focus tool-call-status call) + 'pending-approval) + (acp-message `(("jsonrpc" . "2.0") + ("id" . ,request-id) + ("method" . "session/request_permission") + ("params" + ("sessionId" . ,session-id) + ("toolCall" + ("toolCallId" . ,(tool-call-id call))) + ("options" . + ,(vector %tool-allow-once + %tool-reject-once))))) + call))))))) (define (next-state-llm-response state response tools) "Given current @var{state} and a new LLM @var{response}, return the next state diff --git a/kaakaa/tools.scm b/kaakaa/tools.scm index d975201..cb8fd3c 100644 --- a/kaakaa/tools.scm +++ b/kaakaa/tools.scm @@ -146,7 +146,7 @@ tool-call-failure tool-call-failure? (message tool-call-failure-message)) -(define (spec->tool-call session-id session-cwd tools spec) +(define (spec->tool-call session-id session-cwd tools allowed-tools rejected-tools spec) "Deserialize JSON tool call @var{spec} into a @code{<tool-call>} object. Raise a @code{&tool-call-parse-failure} condition if deserialization fails. @@ -154,7 +154,8 @@ fails. @var{session-id} and @var{session-cwd} are the ID and current working directory of the session the tool call pertains to. @var{tools} is an association list mapping the names of all available tools to their respective @code{<tool>} -objects." +objects. @var{allowed-tools} and @var{rejected-tools} are the lists of tool +names that have been respectively allowed and rejected by the user in advance." ;; TODO: Assert that type is function, and do more sanitization. (let* ((args (guard (c (else (raise-exception @@ -190,7 +191,12 @@ objects." (string-append "Error: Missing required argument " arg-name)))))))) (tool-parameters tool)) - 'pending-approval))) + ;; Set tool call status based on pre-approved and pre-rejected + ;; tools. + (cond + ((member name allowed-tools) 'approved) + ((member name rejected-tools) 'rejected) + (else 'pending-approval))))) (define (eval-tool-call tool-call tools) "Evaluate @var{tool-call} and return a @code{<tool-call-result>} |