diff options
Diffstat (limited to 'kaakaa')
| -rw-r--r-- | kaakaa/config.scm.in | 27 | ||||
| -rw-r--r-- | kaakaa/container.scm | 50 | ||||
| -rw-r--r-- | kaakaa/lens.scm | 62 | ||||
| -rw-r--r-- | kaakaa/openai.scm | 79 | ||||
| -rw-r--r-- | kaakaa/records.scm | 165 | ||||
| -rw-r--r-- | kaakaa/tea.scm | 486 | ||||
| -rw-r--r-- | kaakaa/tools.scm | 256 | ||||
| -rw-r--r-- | kaakaa/tools/base.scm | 54 | ||||
| -rw-r--r-- | kaakaa/utils.scm | 67 |
9 files changed, 1246 insertions, 0 deletions
diff --git a/kaakaa/config.scm.in b/kaakaa/config.scm.in new file mode 100644 index 0000000..2c9e0d2 --- /dev/null +++ b/kaakaa/config.scm.in @@ -0,0 +1,27 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa config) + #:export (%project + %version)) + +(define %project + "@PROJECT@") + +(define %version + "@VERSION@") diff --git a/kaakaa/container.scm b/kaakaa/container.scm new file mode 100644 index 0000000..e7889bb --- /dev/null +++ b/kaakaa/container.scm @@ -0,0 +1,50 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa container) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (gnu build linux-container) + #:use-module (guix utils) + #:use-module (kaakaa records) + #:export (call-with-container*)) + +(define-public-record-type* (<container-result> container-result container-result?) + (fields (output container-result-output) + (exit-value container-result-exit-value))) + +(define (call-with-container* mounts namespaces thunk) + "Run @var{thunk} as a process in a container with @var{mounts} and +@var{namespaces}, and return a @code{<container-result>} object." + (call-with-temporary-directory + (lambda (root) + (match (pipe) + ((in . out) + (match (waitpid (run-container root mounts namespaces 1 + (lambda () + (close-port in) + (with-output-to-port out + ;; TODO: Capture stderr too. + thunk) + (close-port out)))) + ((_ . status) + (close-port out) + (let ((result (get-string-all in))) + (close-port in) + (container-result result + (status:exit-val status)))))))))) diff --git a/kaakaa/lens.scm b/kaakaa/lens.scm new file mode 100644 index 0000000..f5c9370 --- /dev/null +++ b/kaakaa/lens.scm @@ -0,0 +1,62 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa lens) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-43) + #:use-module (lens) + #:export (vector-nth + in-json + push + prepend-over + alist-delete-over)) + +(define (vector-nth n) + "Like @code{nth}, but for vectors." + (lens (cut vector-ref <> n) + (lambda (vec proc) + (vector-append (vector-copy vec 0 n) + (vector (proc (vector-ref vec n))) + (vector-copy vec (1+ n)))))) + +(define in-json + (case-lambda + "Like @code{in}, but also allow integer components so that it is +possible to traverse JSON trees." + (() (id)) + ((key . tail) + (compose (apply in-json tail) + (if (string? key) + (key-ref key) + (vector-nth key)))))) + +(define (push lens x object) + "Cons @var{x} onto the part of @var{object} that @var{lens} focuses +on." + (over lens (cut cons x <>) object)) + +(define (prepend-over lens lst object) + "Prepend @var{lst} to the part of @var{object} that @var{lens} focuses +on." + (over lens (cut append lst <>) object)) + +(define (alist-delete-over lens key object) + "Delete @var{key} from the association list in @var{object} that +@var{lens} focuses on." + (over lens (cut alist-delete key <>) object)) diff --git a/kaakaa/openai.scm b/kaakaa/openai.scm new file mode 100644 index 0000000..08a7254 --- /dev/null +++ b/kaakaa/openai.scm @@ -0,0 +1,79 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa openai) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi srfi-11) + #:use-module (web client) + #:use-module (web http) + #:use-module (web response) + #:use-module (json) + #:export (get-api-key + openai-query)) + +;; TODO: URIs must not be operated on using string operations. Replace with a +;; more principled implementation involving (web uri). +(define (uri-join base uri) + (string-append base uri)) + +(define* (json-post url #:key headers json) + "Send a POST request to @var{url} with @var{json} body and additional +@var{headers}. The @samp{Content-Type} header is set to @samp{application/json} +and need not be specified in @var{headers}. Return JSON response." + (let-values (((response body) + (http-post url + #:headers `((content-type application/json) + ,@headers) + #:body (scm->json-string json) + #:streaming? #t))) + ;; Guile does not consider application/json responses as textual, and does + ;; not automatically set the port encoding to UTF-8. + (set-port-encoding! body "UTF-8") + (case (quotient (response-code response) + 100) + ((2) (json->scm body)) + ((4) + (raise-exception + (condition (make-violation) + (make-message-condition + (string-append "JSON API request failed with client error code " + (number->string (response-code response))))))) + (else + (raise-exception + (condition (make-error) + (make-message-condition + (string-append "JSON API request failed with code " + (number->string (response-code response)))))))))) + +;; Declare the Authorization header as opaque so that Guile doesn't try to mess +;; with it. +(declare-opaque-header! "Authorization") + +(define (openai-query base-uri api-key model messages tools) + "Send a request to the OpenAI completions API and return the JSON response. +@var{base-uri} is the base URI of the OpenAI-compatible service. @var{api-key} +is the API key for authentication. @var{model} is a supported LLM model. +@var{messages} and @var{tools} are respectively lists of JSON messages and tools +compatible with the OpenAI API specification." + (json-post (uri-join base-uri "/api/v1/chat/completions") + #:headers `((authorization + . ,(string-append "Bearer " api-key))) + #:json `(("model" . ,model) + ("messages" . ,(list->vector messages)) + ("tools" . ,(list->vector tools))))) diff --git a/kaakaa/records.scm b/kaakaa/records.scm new file mode 100644 index 0000000..7cdac66 --- /dev/null +++ b/kaakaa/records.scm @@ -0,0 +1,165 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa records) + #:use-module (rnrs records procedural) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (lens) + #:export (define-record-type* + define-public-record-type*)) + +(define (make-record-type* record-name make-constructor . fields) + "Create a record type with @var{record-name} and @var{fields}. +@var{make-constructor} is a function that is passed a basic record constructor +accepting positional arguments and must return the record constructor. Return +@code{length(fields) + 3} values---the record type descriptor, the record +constructor, the record predicate and the field accessors. + +@var{fields} is a list of field specifiers each of which is of the form +@code{(field-name accessor-type)}. @var{accessor-type} is either +@code{'accessor} or @code{'lensed}." + (let* ((rtd (make-record-type-descriptor record-name #f #f #f #f + (list->vector (map (match-lambda + ((field-name _) + field-name)) + fields)))) + (constructor (record-constructor + (make-record-constructor-descriptor rtd #f #f))) + (accessors (map (cut record-accessor rtd <>) + (iota (length fields))))) + (apply values + rtd + (make-constructor constructor) + (record-predicate rtd) + (map (match-lambda* + ((_ accessor (_ 'accessor)) + accessor) + ((index accessor (_ 'lensed)) + (lens accessor + (lambda (record proc) + (apply constructor + (append (map (lambda (accessor) + (accessor record)) + (take accessors index)) + (list (proc ((list-ref accessors index) + record))) + (map (lambda (accessor) + (accessor record)) + (drop accessors (1+ index))))))))) + (iota (length fields)) + accessors + fields)))) + +(define-syntax define-record-type* + (lambda (x) + "Define a record type. All fields are immutable and may optionally have lenses as +accessors. + +Lenses are procedures that combine getters and setters into one structure. They +allow you to conveniently manipulate parts of deeply nested data structures in a +composable and purely functional way. + +Consider the following example record definition: +@example +(define-record-type* (<employee> employee employee?) + (name employee-name) + (age employee-age lensed) + (salary employee-salary lensed)) +@end example +In this example, @code{employee-name} is a regular accessor, while +@code{employee-age} and @code{employee-salary} are lenses. + +@code{employee-name} is a regular accessor. Get with: +@example +(employee-name x) +@end example + +@code{employee-age} is a lens. Get with: +@example +(focus employee-age x) +@end example + +Functionally update with: +@example +(put employee-age 25 x) +@end example + +Record definitions may also optionally specify a @code{make-constructor} +argument which is passed to @code{make-record-type*}. For example: +@example +(define-record-type* (<employee> employee employee?) + (lambda (constructor) + (lambda* (name #:key age salary) + (constructor name age salary))) + (fields (name employee-name) + (age employee-age lensed) + (salary employee-salary lensed))) +@end example +" + (syntax-case x (fields) + ((_ (record-name constructor-name predicate-name) + make-constructor + (fields field-spec ...)) + #`(define-values (record-name constructor-name predicate-name + #,@(map (lambda (x) + (syntax-case x () + ((_ accessor-name _ ...) + #'accessor-name))) + #'(field-spec ...))) + (make-record-type* 'record-name + make-constructor + #,@(map (lambda (x) + (syntax-case x (lensed) + ((field-name accessor-name) + #''(field-name accessor)) + ((field-name accessor-name lensed) + #''(field-name lensed)))) + #'(field-spec ...))) + )) + ((_ (record-name constructor-name predicate-name) + (fields field-spec ...)) + #'(define-record-type* (record-name constructor-name predicate-name) + identity + (fields field-spec ...)))))) + +(define-syntax define-public-record-type* + (lambda (x) + "Like @code{define-record-type*}, but also export the constructor, the predicate +and the accessors." + (syntax-case x (fields) + ((_ (record-name constructor-name predicate-name) + make-constructor + (fields field-spec ...)) + #`(begin + (define-record-type* (record-name constructor-name predicate-name) + make-constructor + (fields field-spec ...)) + (export constructor-name) + (export predicate-name) + #,@(map (lambda (x) + (syntax-case x () + ((_ accessor-name _ ...) + #'(export accessor-name)))) + #'(field-spec ...)))) + ((_ (record-name constructor-name predicate-name) + (fields field-spec ...)) + #'(define-public-record-type* (record-name constructor-name predicate-name) + identity + (fields field-spec ...)))))) diff --git a/kaakaa/tea.scm b/kaakaa/tea.scm new file mode 100644 index 0000000..b57e56e --- /dev/null +++ b/kaakaa/tea.scm @@ -0,0 +1,486 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa tea) + #:use-module (rnrs io ports) + #:use-module (rnrs records syntactic) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (json) + #:use-module (lens) + #:use-module (kaakaa lens) + #:use-module (kaakaa openai) + #:use-module (kaakaa records) + #:use-module (kaakaa tools) + #:use-module (kaakaa utils) + #:export (initial-state + tea-loop)) + +(define %tool-allow-once + '(("optionId" . "allow-once") + ("name" . "Allow once") + ("kind" . "allow_once"))) + +(define %tool-reject-once + '(("optionId" . "reject-once") + ("name" . "Reject once") + ("kind" . "reject_once"))) + +(define-record-type* (<session> session session?) + (lambda (constructor) + (lambda* (cwd #:key cancelling? (messages '()) (pending-tool-calls '())) + (constructor cwd cancelling? messages pending-tool-calls))) + (fields (cwd session-cwd lensed) + (cancelling? session-cancelling? lensed) + (messages session-messages lensed) + (tool-calls session-tool-calls lensed))) + +(define-record-type* (<state> state state?) + (fields (client-request-id state-client-request-id lensed) + (agent-request-id state-agent-request-id lensed) + (next-session-id state-next-session-id lensed) + ;; Association list mapping agent request IDs to tool calls + ;; for which permission is sought + (requests-alist state-requests-alist lensed) + (sessions state-sessions lensed))) + +(define (initial-state) + (state #f 0 0 '() '())) + +(define-record-type* (<llm-request> llm-request llm-request?) + (fields (session-id llm-request-session-id) + (messages llm-request-messages))) + +(define-record-type* (<llm-response> llm-response llm-response?) + (fields (session-id llm-response-session-id) + (json llm-response-json))) + +(define-record-type* (<acp-message> acp-message acp-message?) + (fields (json acp-message-json))) + +(define (state-messages session-id) + "Return a lens to focus on messages of session with @var{session-id} in +state." + (compose session-messages + (key-ref session-id) + state-sessions)) + +(define (state-tool-calls session-id) + "Return a lens to focus on tool calls of session with @var{session-id} +in state." + (compose session-tool-calls + (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." + (compose (key-ref tool-call-id) + (state-tool-calls session-id))) + +(define (state-session-cancelling? session-id) + "Return a lens to focus on the @code{cancelling?} flag of session with +@var{session-id} in state." + (compose session-cancelling? + (key-ref session-id) + state-sessions)) + +(define (state->llm-request session-id state) + "Return an @code{<llm-request>} for session with @var{session-id} in +@var{state}." + (llm-request session-id + (map (lambda (message) + ;; Strip out all fields (such as reasoning + ;; fields) other than role, content and + ;; tool_calls. + (filter (match-lambda + ((key . _) + (member key (list "role" "content" + "tool_calls")))) + message)) + ;; Reverse because we have been prepending new + ;; messages onto the list. + (reverse (focus (state-messages session-id) + state))))) + +(define (next-state-client-request state request) + "Given current @var{state} and a new ACP @var{request}, return the +next state and a list of effects." + (let ((request-id (focus (key-ref "id") + request))) + (cond + ;; There is a pending request from the client; process it. + ((focus (key-ref "method") request) + => (match-lambda + ("initialize" + (values state + (list (acp-message `(("jsonrpc" . "2.0") + ("id" . ,request-id) + ("result" + ("protocolVersion" . 1) + ("agentCapabilities") + ("agentInfo" + ("name" . "kaakaa") + ("title" . "Kaakaa") + ("version" . "0.1.0")) + ("authMethods" . #()))))))) + ("session/new" + (let ((session-id + (string-append "session-" + (number->string + (focus state-next-session-id state))))) + (values (-> state + ;; Push new session onto list. + (push state-sessions + (cons session-id + ;; TODO: Check if cwd is an + ;; absolute path. + (session (focus (in "params" "cwd") + request))) + <>) + ;; Increment next session ID. + (over state-next-session-id + 1+ + <>)) + (list (acp-message `(("jsonrpc" . "2.0") + ("id" . ,request-id) + ("result" + ("sessionId" . ,session-id)))))))) + ("session/prompt" + (let* ((session-id (focus (in "params" "sessionId") + request)) + (state (push (state-messages session-id) + `(("role" . "user") + ("content" . + ;; TODO: Filter to only allow + ;; "text" type content blocks. + ,(focus (in "params" "prompt") + request))) + state))) + (values state + (list (state->llm-request session-id state))))) + ("session/cancel" + (let ((session-id (focus (in "params" "sessionId") + request))) + ;; Reset state and end the prompt turn. + (values (-> state + (put (state-session-cancelling? session-id) + #f + <>) + (put (state-tool-calls session-id) + '() + <>) + (put state-requests-alist + '() + <>)) + (list (acp-message `(("jsonrpc" . "2.0") + ("id" . ,(focus state-client-request-id + state)) + ("result" + ("stopReason" . "cancelled"))))))))))))) + +(define (next-state-client-response state response) + "Given current @var{state} and a new ACP @var{response}, return the +next state and a list of effects." + (let ((request-id (focus (key-ref "id") + response))) + (cond + ;; The tool call for this response has been found; process it. + ((focus (compose (key-ref request-id) + state-requests-alist) + state) + => (lambda (tool-call) + (let* ((session-id (tool-call-session-id tool-call)) + (outcome (focus (in "result" "outcome") + response)) + (outcome-type (focus (key-ref "outcome") + outcome)) + (state + (-> state + ;; Update tool status. + (put (compose tool-call-status + (state-tool-call (tool-call-id tool-call) + session-id)) + ;; TODO: Implement other tool permissions. + (cond + ((string=? outcome-type "cancelled") + 'cancelled) + ((and (string=? outcome-type "selected") + (string=? (focus (key-ref "optionId") + outcome) + (focus (key-ref "optionId") + %tool-allow-once))) + 'approved) + (else 'rejected)) + <>) + ;; If the tool call was cancelled, set the + ;; cancelling flag to indicate that a + ;; cancellation is in progress. + (put (state-session-cancelling? session-id) + (string=? outcome-type "cancelled") + <>) + ;; Unregister request corresponding to this + ;; response. + (alist-delete-over state-requests-alist + request-id + <>)))) + (values state + ;; Request tool call evaluation. eval-tool-call + ;; handles cancelled and rejected tool calls + ;; correctly. We don't have to worry about it + ;; here. + (list (focus (state-tool-call (tool-call-id tool-call) + (tool-call-session-id tool-call)) + state)))))) + ;; Client response is stale (it pertains to a request not in + ;; requests-alist). Silently ignore it. + (else (values state '()))))) + +(define (next-state-llm-response state response) + "Given current @var{state} and a new LLM @var{response}, return the +next state and a list of effects." + (let* ((session-id (llm-response-session-id response)) + (llm-reply (focus (in-json "choices" 0 "message") + (llm-response-json response))) + (tool-calls (cond + ((focus (key-ref "tool_calls") + llm-reply) + => (lambda (json) + (map (cut spec->tool-call + session-id + (focus (compose session-cwd + (key-ref session-id) + state-sessions) + state) + <>) + (vector->list json)))) + (else '()))) + (request-ids (iota (length tool-calls) + (focus state-agent-request-id + state)))) + (values (-> state + ;; Push LLM response onto messages. + (push (state-messages session-id) + llm-reply + <>) + ;; Queue new tool calls. + (prepend-over (state-tool-calls session-id) + (map (lambda (tool-call) + (cons (tool-call-id tool-call) + tool-call)) + tool-calls) + <>) + ;; Register this request so we can recall the details + ;; later when the response comes in. + (prepend-over state-requests-alist + (map cons + request-ids + tool-calls) + <>) + ;; Bump up agent request ID by the number of IDs used. + (over state-agent-request-id + (cut + (length tool-calls) <>) + <>)) + (map acp-message + (append `( ;; Send LLM's text response. + (("jsonrpc" . "2.0") + ("method" . "session/update") + ("params" + ("sessionId" . ,session-id) + ("update" + ("sessionUpdate" . "agent_message_chunk") + ("content" + ("type" . "text") + ("text" . ,(focus (key-ref "content") + llm-reply))))))) + ;; Request permission from the client. + (map (lambda (call request-id) + `(("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))))) + tool-calls + request-ids) + ;; End prompt turn if there are no further + ;; tool calls and a cancellation is not in + ;; progress. + (if (and (null? tool-calls) + (not (focus (state-session-cancelling? session-id) + state))) + `((("jsonrpc" . "2.0") + ("id" . ,(focus state-client-request-id + state)) + ("result" + ("stopReason" . "end_turn")))) + '())))))) + +(define (next-state-tool-call-result state result) + "Given current @var{state} and a new tool call @var{result}, return the +next state and a list of effects." + (let* ((session-id (tool-call-result-session-id result)) + (state (-> state + ;; Push tool call result onto messages. + (push (state-messages session-id) + (tool-call-result-json result) + <>) + ;; Delete tool call from session tool call list. + (alist-delete-over (state-tool-calls session-id) + (tool-call-result-call-id result) + <>)))) + (values state + ;; Send a notification for each tool call evaluated. + (cons (acp-message `(("jsonrpc" . "2.0") + ("method" . "session/update") + ("params" + ("sessionId" . ,session-id) + ("update" + ;; TODO: Add locations and + ;; rawOutput. + ("sessionUpdate" . "tool_call") + ("toolCallId" . ,(tool-call-result-call-id result)) + ("title" . ,(tool-call-result-title result)) + ("kind" . ,(tool-call-result-kind result)) + ("status" . + ,(if (tool-call-result-success? result) + "completed" + "failed")) + ("content" + ("type" . "content") + ("content" + ("type" . "text") + ("text" . ,(focus (key-ref "content") + (tool-call-result-json result))))) + ("rawInput" . ,(tool-call-result-arguments result)))))) + ;; If there are no more tool calls and a + ;; cancellation is not in progress, dispatch to LLM. + (if (and (null? (focus (state-tool-calls session-id) + state)) + (not (focus (state-session-cancelling? session-id) + state))) + (list (state->llm-request session-id state)) + (list)))))) + +(define (next-state state message) + "Given current @var{state} and a new @var{message}, return the next +state and a list of effects." + (cond + ((acp-message? message) + (let ((json-message (acp-message-json message))) + (if (focus (key-ref "result") json-message) + ;; message is a response from the client. + (next-state-client-response state json-message) + ;; message is a request/notification from the client. + (let-values (((state effects) + (next-state-client-request state json-message))) + (values (cond + ;; message is a request from the client. + ((focus (key-ref "id") json-message) + => (cut put + state-client-request-id + <> + state)) + ;; message is a notification from the client. + (else state)) + effects))))) + ((llm-response? message) + (next-state-llm-response state message)) + ((tool-call-result? message) + (next-state-tool-call-result state message)))) + +(define (tea-loop state llm-base-uri llm-api-key model tools) + "Run a @acronym{TEA, The Elm Architecture} loop starting with +@var{state}. + +@var{llm-base-uri} is the base URI of the LLM provider. +@var{llm-api-key} is the API key to authenticate with the LLM +provider. @var{model} is the name of the model. @var{tools} is the +list of tools made available to the LLM. It is an association list +matching tool names to @code{<tool>} objects." + ;; Read a JSON-RPC message, handle it, and loop. + (let ((line (get-line (current-input-port)))) + (unless (eof-object? line) + (tea-loop (handle-event (acp-message (json-string->scm line)) + state + llm-base-uri + llm-api-key + model + tools) + llm-base-uri + llm-api-key + model + tools)))) + +(define (handle-event event state llm-base-uri llm-api-key model tools) + "Handle @var{event} with @var{state} and return a new state. + +@var{llm-base-uri}, @var{llm-api-key}, @var{model} and @var{tools} are +the same as in @code{tea-loop}." + (let-values (((state effects) + ;; Compute the next state and collect the effects. + (next-state state event))) + ;; Do the effects. + (fold (cut do-effect <> <> llm-base-uri llm-api-key model tools) + state + effects))) + +(define (do-effect effect state llm-base-uri llm-api-key model tools) + "Do @var{effect} with @var{state} and return a new state. + +@var{llm-base-uri}, @var{llm-api-key}, @var{model} and @var{tools} are +the same as in @code{tea-loop}." + (cond + ;; Send message to client, and return the state unchanged. + ((acp-message? effect) + (display (scm->json-string (acp-message-json effect))) + (newline) + (flush-output-port (current-output-port)) + state) + ;; Send request to LLM, handle the response, and return the new + ;; state. + ((llm-request? effect) + ;; TODO: Handle network failures in OpenAI query. + (handle-event (llm-response (llm-request-session-id effect) + (openai-query llm-base-uri + llm-api-key + model + (llm-request-messages effect) + (map (match-lambda + ((name . tool) + (tool->spec name tool))) + tools))) + state + llm-base-uri + llm-api-key + model + tools)) + ;; Evaluate tool, handle the result, and return the new state. + ((tool-call? effect) + (handle-event (eval-tool-call effect tools) + state + llm-base-uri + llm-api-key + model + tools)))) diff --git a/kaakaa/tools.scm b/kaakaa/tools.scm new file mode 100644 index 0000000..b490852 --- /dev/null +++ b/kaakaa/tools.scm @@ -0,0 +1,256 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa tools) + #:use-module ((rnrs base) #:select (assertion-violation)) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (rnrs records syntactic) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (gnu build linux-container) + #:use-module (gnu system file-systems) + #:use-module (json) + #:use-module (lens) + #:use-module (kaakaa container) + #:use-module (kaakaa records) + #:use-module (kaakaa utils) + #:export (tool->spec + spec->tool-call + eval-tool-call)) + +(define (readonly-cwd-only-mappings cwd arguments) + (list (file-system-mapping + (source cwd) + (target source) + (writable? #f)))) + +(define-public-record-type* (<tool> tool tool?) + (lambda (constructor) + (lambda* (#:key + description (parameters '()) proc + (container-mappings readonly-cwd-only-mappings) + (container-namespaces %namespaces) + title kind) + (unless description + (raise-exception + (condition (make-violation) + (make-message-condition "tool requires description")))) + (unless proc + (raise-exception + (condition (make-violation) + (make-message-condition "tool requires proc")))) + (constructor description parameters proc + container-mappings container-namespaces title kind))) + (fields (description tool-description) + ;; Association list mapping parameter names to + ;; <tool-parameter> objects. + (parameters tool-parameters) + (proc tool-proc) + (container-mappings tool-container-mappings) + (container-namespaces tool-container-namespaces) + (title tool-title) + (kind tool-kind))) + +(define-public-record-type* (<tool-parameter> tool-parameter tool-parameter?) + (lambda (constructor) + (lambda* (#:key type description (required? #t)) + (unless type + (raise-exception + (condition (make-violation) + (make-message-condition "tool parameter requires type")))) + (unless description + (raise-exception + (condition (make-violation) + (make-message-condition "tool parameter requires description")))) + (constructor type description required?))) + (fields (type tool-parameter-type) + (description tool-parameter-description) + (required? tool-parameter-required?))) + +(define-public-record-type* (<array-type> array-type array-type?) + (fields (subtype array-type-subtype))) + +(define (tool->spec name tool) + "Serialize @var{tool} of @var{name} to OpenAI-compatible JSON spec." + `(("type" . "function") + ("function" + ("name" . ,name) + ("description" . ,(tool-description tool)) + ("parameters" + ("type" . "object") + ("properties" . + ,(map (match-lambda + ((name . parameter) + ;; TODO: Check if the OpenAI API supports arrays of + ;; arrays and other more deeply nested types. + (let ((type (tool-parameter-type parameter))) + `(,name + ("description" . ,(tool-parameter-description parameter)) + ("type" . ,(if (array-type? type) + "array" + type)) + ,@(if (array-type? type) + `(("items" . ,(array-type-subtype type))) + '()))))) + (tool-parameters tool))) + ("required" . + ,(list->vector + (filter-map (match-lambda + ((name . parameter) + (and (tool-parameter-required? parameter) + name))) + (tool-parameters tool)))))))) + +(define-public-record-type* (<tool-call> tool-call tool-call?) + (fields (session-id tool-call-session-id) + (session-cwd tool-call-session-cwd) + (id tool-call-id) + (function tool-call-function) + (arguments tool-call-arguments) + ;; One of 'approved, 'rejected or 'cancelled + (status tool-call-status lensed))) + +(define-public-record-type* (<tool-call-result> tool-call-result tool-call-result?) + (fields (session-id tool-call-result-session-id) + (call-id tool-call-result-call-id) + (title tool-call-result-title) + (kind tool-call-result-kind) + (arguments tool-call-result-arguments) + (json tool-call-result-json) + (success? tool-call-result-success?))) + +(define-condition-type &tool-call-failure &serious + tool-call-failure tool-call-failure? + (message tool-call-failure-message)) + +(define (spec->tool-call session-id session-cwd spec) + "Deserialize JSON tool call @var{spec} into a @code{<tool-call>} +object. @var{session-id} and @var{session-cwd} are the ID and current working +directory of the session the tool call pertains to." + ;; TODO: Assert that type is function, and do more sanitization. + (tool-call session-id + session-cwd + (focus (key-ref "id") + spec) + (focus (in "function" "name") + spec) + ;; The arguments may be invalid JSON. So, we don't deserialize + ;; right away. + (focus (in "function" "arguments") + spec) + 'pending-approval)) + +(define (eval-tool-call tool-call tools) + "Evaluate @var{tool-call} and return a @code{<tool-call-result>} +object. @var{tools} is an association list mapping the names of all +available tools to their respective @code{<tool>} objects." + (cond + ((focus (key-ref (tool-call-function tool-call)) + tools) + => (lambda (tool) + (case (focus tool-call-status tool-call) + ;; User approved tool call. + ((approved) + (guard (c ((tool-call-failure? c) + (tool-call-result (tool-call-session-id tool-call) + (tool-call-id tool-call) + #f + #f + (tool-call-arguments tool-call) + `(("role" . "tool") + ("tool_call_id" . ,(tool-call-id tool-call)) + ("content" . ,(tool-call-failure-message c))) + #f))) + (let* ((args + ;; Deserialize arguments checking for valid JSON. + (guard (c (else + (raise-exception + (tool-call-failure + "Error: Arguments are not valid JSON")))) + (json-string->scm (tool-call-arguments tool-call)))) + (filtered-args + ;; Only pick out valid arguments, and error out if any + ;; required arguments are missing. + (alist->plist + (filter-map (match-lambda + ((arg-name . parameter) + (cond + ((assoc arg-name args) + => identity) + (else + (and (tool-parameter-required? parameter) + (raise-exception + (tool-call-failure + (string-append "Error: Missing required argument " + arg-name)))))))) + (tool-parameters tool)))) + ;; Actually evaluate tool call. + (tool-result + (call-with-container* + (map file-system-mapping->bind-mount + ((tool-container-mappings tool) + (tool-call-session-cwd tool-call) + filtered-args)) + (tool-container-namespaces tool) + (lambda () + (chdir (tool-call-session-cwd tool-call)) + (apply (tool-proc tool) + filtered-args))))) + ;; Build result. + (tool-call-result (tool-call-session-id tool-call) + (tool-call-id tool-call) + (apply (tool-title tool) filtered-args) + (apply (tool-kind tool) filtered-args) + (tool-call-arguments tool-call) + `(("role" . "tool") + ("tool_call_id" . ,(tool-call-id tool-call)) + ("content" . ,(container-result-output tool-result))) + (zero? (container-result-exit-value tool-result)))))) + ;; User cancelled or rejected tool call. + ((cancelled rejected) + (tool-call-result (tool-call-session-id tool-call) + (tool-call-id tool-call) + #f + #f + (tool-call-arguments tool-call) + `(("role" . "tool") + ("tool_call_id" . ,(tool-call-id tool-call)) + ("content" . + ,(case (focus tool-call-status tool-call) + ((rejected) + "Error: User denied permission for this tool call") + ((cancelled) + "Error: User cancelled this tool call")))) + #f)) + (else + (assertion-violation (focus tool-call-status tool-call) + "Invalid tool call status"))))) + (else + (tool-call-result (tool-call-session-id tool-call) + (tool-call-id tool-call) + #f + #f + (tool-call-arguments tool-call) + `(("role" . "tool") + ("tool_call_id" . ,(tool-call-id tool-call)) + ("content" . + ,(string-append "Error: Function of name " + (tool-call-function tool-call) + " not found"))) + #f)))) diff --git a/kaakaa/tools/base.scm b/kaakaa/tools/base.scm new file mode 100644 index 0000000..38aed17 --- /dev/null +++ b/kaakaa/tools/base.scm @@ -0,0 +1,54 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa tools base) + #:use-module (rnrs io ports) + #:use-module (guix build utils) + #:use-module (kaakaa tools) + #:export (%list-files + %base-tools)) + +(define %read + (tool #:description "Read file" + #:parameters `(("path" . ,(tool-parameter + #:type "string" + #:description "File path to read" + #:required? #t))) + #:proc (lambda* (#:key path) + ;; TODO: Handle non-existent files. + (display (call-with-input-file path + get-string-all))) + #:title (const "Read file") + #:kind (const "read"))) + +(define %list-files + (tool #:description "List files in current directory" + #:parameters (list) + #:proc (lambda _ + (for-each (lambda (file) + (display file) + (newline)) + (find-files (getcwd)))) + #:title (const "List files") + #:kind (const "read"))) + +(define %base-tools + `(("read" . ,%read) + ("list-files" . ,%list-files))) + +;; TODO: Implement write, grep and find. diff --git a/kaakaa/utils.scm b/kaakaa/utils.scm new file mode 100644 index 0000000..5677af2 --- /dev/null +++ b/kaakaa/utils.scm @@ -0,0 +1,67 @@ +;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kaakaa. +;;; +;;; kaakaa is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; kaakaa is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>. + +(define-module (kaakaa utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:export (-> + alist->plist + call-with-input-pipe)) + +(define (->-helper x . procs) + "Thread @var{x} through @var{procs}." + (match procs + (() x) + ((head tail ...) + (apply ->-helper (head x) tail)))) + +(define-syntax-rule (-> x (proc ...) ...) + "Thread @var{x} through @var{procs}. + +For example: +(-> 1 + (1+ <>) + (* 2 <>) + (expt <> 2)) +=> 16" + (->-helper x (cut proc ...) ...)) + +(define (alist->plist alist) + "Convert association list @var{alist} to a property list. Keys in +@var{alist} are converted to keywords." + (append-map (match-lambda + ((key . value) + (list (symbol->keyword (string->symbol key)) + value))) + alist)) + +(define (call-with-input-pipe command proc) + "Call @var{proc} with input pipe to @var{command}. @var{command} is a +list of program arguments." + (match command + ((prog args ...) + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port (apply open-pipe* OPEN_READ prog args))) + (cut proc port) + (lambda () + (unless (zero? (close-pipe port)) + (error "Command invocation failed" command)))))))) |