diff options
| author | Arun Isaac | 2026-04-12 18:09:49 +0100 |
|---|---|---|
| committer | Arun Isaac | 2026-04-12 18:09:49 +0100 |
| commit | fe32909d58a59407350043851970cb3004ad351e (patch) | |
| tree | 3e8d58df44ffd2de4b926f876b33081d3f285b59 /kaakaa | |
| parent | 968c5f2c9df53139729aa5356ad5a802d1c88f37 (diff) | |
| download | kaagum-fe32909d58a59407350043851970cb3004ad351e.tar.gz kaagum-fe32909d58a59407350043851970cb3004ad351e.tar.lz kaagum-fe32909d58a59407350043851970cb3004ad351e.zip | |
Rename project to kaagum.
kaakaa reminds too many Europeans of shit. 😅
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 | 784 | ||||
| -rw-r--r-- | kaakaa/tools.scm | 261 | ||||
| -rw-r--r-- | kaakaa/tools/base.scm | 225 | ||||
| -rw-r--r-- | kaakaa/utils.scm | 89 |
9 files changed, 0 insertions, 1742 deletions
diff --git a/kaakaa/config.scm.in b/kaakaa/config.scm.in deleted file mode 100644 index 2c9e0d2..0000000 --- a/kaakaa/config.scm.in +++ /dev/null @@ -1,27 +0,0 @@ -;;; 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 deleted file mode 100644 index e7889bb..0000000 --- a/kaakaa/container.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;; 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 deleted file mode 100644 index f5c9370..0000000 --- a/kaakaa/lens.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;; 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 deleted file mode 100644 index 08a7254..0000000 --- a/kaakaa/openai.scm +++ /dev/null @@ -1,79 +0,0 @@ -;;; 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 deleted file mode 100644 index 7cdac66..0000000 --- a/kaakaa/records.scm +++ /dev/null @@ -1,165 +0,0 @@ -;;; 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 deleted file mode 100644 index 1660636..0000000 --- a/kaakaa/tea.scm +++ /dev/null @@ -1,784 +0,0 @@ -;;; 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 base) #:select (assertion-violation)) - #:use-module (rnrs exceptions) - #: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 (ice-9 regex) - #: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-allow-always - '(("optionId" . "allow-always") - ("name" . "Allow always") - ("kind" . "allow_always"))) - -(define %tool-reject-once - '(("optionId" . "reject-once") - ("name" . "Reject once") - ("kind" . "reject_once"))) - -(define %tool-reject-always - '(("optionId" . "reject-always") - ("name" . "Reject always") - ("kind" . "reject_always"))) - -(define-record-type* (<session> session session?) - (lambda (constructor) - (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) - ;; 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) - (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 (state-cwd session-id) - "Return a lens to focus on current working directory of session with -@var{session-id} in state." - (compose session-cwd - (key-ref session-id) - state-sessions)) - -(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-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." - (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-requests session-id state) - "Return a list of @code{<llm-request>} objects for session with @var{session-id} -in @var{state}." - (if (and (null? (focus (state-tool-calls session-id) - state)) - (not (focus (state-session-cancelling? session-id) - state))) - ;; There are no more tool calls in flight and a cancellation is not in - ;; progress; dispatch to LLM. - (list (llm-request session-id - (map (lambda (message) - ;; Strip unnecessary fields (such as reasoning - ;; fields) based on role. - (let* ((role (focus (key-ref "role") message)) - (allowed-fields - (cond - ((string=? role "user") - '("role" "content")) - ((string=? role "assistant") - '("role" "content" "tool_calls")) - ((string=? role "tool") - '("role" "content" "tool_call_id"))))) - (filter (match-lambda - ((key . _) - (member key allowed-fields))) - message))) - ;; Reverse because we have been prepending new - ;; messages onto the list. - (reverse (focus (state-messages session-id) - state))))) - ;; There are tool calls or a cancellation in progress; do nothing. - (list))) - -(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 lensed))) - -(define-record-type* (<command> command command?) - (fields (description command-description) - (next-state command-next-state))) - -(define (command->spec name command) - "Serialize @var{command} of @var{name} to ACP-compatible JSON spec." - `(("name" . ,name) - ("description" . ,(command-description command)))) - -(define (agent-message-chunk session-id text) - "Return an @samp{agent_message_chunk} @samp{session/update} ACP message for -@var{session-id} with @var{text}." - (acp-message `(("jsonrpc" . "2.0") - ("method" . "session/update") - ("params" - ("sessionId" . ,session-id) - ("update" - ("sessionUpdate" . "agent_message_chunk") - ("content" - ("type" . "text") - ("text" . ,text))))))) - -(define %cwd-command - (command "Print current working directory of the session" - (lambda (state session-id tools argument) - (values state - (list (agent-message-chunk session-id - (focus (state-cwd session-id) - state))))))) - -(define (markdown-table lines) - "Return a markdown table built from @var{lines}. Each line is a list of strings, -each string the contents of a cell. The first line is considered the header of -the table." - (define (cells->line cells) - (string-append "| " - (string-join cells " | ") - " |")) - - (match lines - ((header other-lines ...) - (string-join (cons* (cells->line header) - (cells->line (make-list (length header) "---")) - (map cells->line - other-lines)) - "\n")))) - -(define %tools-command - (command "List available tools and their permission status" - (lambda (state session-id tools argument) - (let* ((allowed-tools (focus (state-allowed-tools session-id) - state)) - (rejected-tools (focus (state-rejected-tools session-id) - state)) - (lines - (cons (list "Tool" "Permission") - (map (match-lambda - ((name . _) - (list name - (cond - ((member name allowed-tools) "allow") - ((member name rejected-tools) "reject") - (else "prompt user"))))) - tools)))) - (values state - (list (agent-message-chunk session-id - (markdown-table lines)))))))) - -(define %commands - `(("cwd" . ,%cwd-command) - ("tools" . ,%tools-command))) - -(define (next-state-slash-command state session-id tools command-name argument) - "Given current @var{state} and an invocation of slash var{command-name} with -@var{argument} for @var{session-id}, return the next state and a list of -effects. - -@var{tools} is the same as in @code{tea-loop}." - (cond - ;; command exists - ((focus (key-ref command-name) - %commands) - => (lambda (command) - ((command-next-state command) state session-id tools argument))) - ;; command not found - (else - (values state - (list (agent-message-chunk session-id - "Error: Unknown command")))))) - -(define (next-state-client-request state request tools) - "Given current @var{state} and a new ACP @var{request}, return the next state and -a list of effects. - -@var{tools} is the same as in @code{tea-loop}." - (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+ - <>)) - (map acp-message - `(;; Return new session. - (("jsonrpc" . "2.0") - ("id" . ,request-id) - ("result" - ("sessionId" . ,session-id))) - ;; Advertise available commands. - (("jsonrpc" . "2.0") - ("method" . "session/update") - ("params" - ("sessionId" . ,session-id) - ("update" - ("sessionUpdate" . "available_commands_update") - ("availableCommands" . - ,(list->vector (map (match-lambda - ((name . command) - (command->spec name command))) - %commands))))))))))) - ("session/prompt" - (let ((session-id (focus (in "params" "sessionId") - request)) - ;; TODO: Filter to only allow "text" type content blocks. - (prompt (focus (in "params" "prompt") - request))) - (cond - ;; slash command - ((string-match "^/([a-z0-9]*)(.*)" - (focus (in-json 0 "text") - prompt)) - => (lambda (mtch) - (let ((command-name (match:substring mtch 1)) - (argument (string-trim (match:substring mtch 2)))) - (let-values (((state effects) - (next-state-slash-command - state session-id tools command-name argument))) - (values state - ;; End prompt turn immediately. This means - ;; slash commands cannot send LLM requests or - ;; initiate other exchanges. - (append effects - (list (acp-message - `(("jsonrpc" . "2.0") - ("id" . ,request-id) - ("result" - ("stopReason" . "end_turn"))))))))))) - ;; regular prompt - (else - (let ((state (push (state-messages session-id) - `(("role" . "user") - ("content" . ,prompt)) - state))) - (values state - (state->llm-requests 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" "outcome") - response)) - (option-id (focus (in "result" "outcome" "optionId") - response)) - ;; Decode permission selection to symbol. - (selection - (cond - ((and (string=? outcome "selected") - (string=? option-id - (focus (key-ref "optionId") %tool-allow-once))) - 'allow-once) - ((and (string=? outcome "selected") - (string=? option-id - (focus (key-ref "optionId") %tool-allow-always))) - 'allow-always) - ((and (string=? outcome "selected") - (string=? option-id - (focus (key-ref "optionId") %tool-reject-once))) - 'reject-once) - ((and (string=? outcome "selected") - (string=? option-id - (focus (key-ref "optionId") %tool-reject-always))) - 'reject-always) - ;; We don't explicitly look for "cancelled". We defensively - ;; assume anything other than "selected" is "cancelled". - ;; This protects us from buggy clients. - (else 'cancel))) - (state - (-> state - ;; If the tool was "allowed always", add it to the list - ;; of allowed tools. - (over (state-allowed-tools session-id) - (lambda (allowed-tools) - (if (eq? selection 'allow-always) - (cons (tool-call-function tool-call) - allowed-tools) - allowed-tools)) - <>) - ;; If the tool was "rejected always", add it to the list - ;; of rejected tools. - (over (state-rejected-tools session-id) - (lambda (rejected-tools) - (if (eq? selection 'reject-always) - (cons (tool-call-function tool-call) - rejected-tools) - rejected-tools)) - <>) - ;; Update tool status. - (put (compose tool-call-status - (state-tool-call (tool-call-id tool-call) - session-id)) - (cond - ((eq? selection 'cancel) 'cancelled) - ((memq selection '(allow-once allow-always)) - 'approved) - ((memq selection '(reject-once reject-always)) - 'rejected) - ;; This branch should be unreachable. - (else - (assertion-violation selection - "Invalid selection"))) - <>) - ;; Update tool status. - (put (compose tool-call-status - (state-tool-call (tool-call-id tool-call) - session-id)) - (cond - ((eq? selection 'cancel) 'cancelled) - ((memq selection '(allow-once allow-always)) - 'approved) - ((memq selection '(reject-once reject-always)) - 'rejected) - ;; This branch should be unreachable. - (else - (assertion-violation selection - "Invalid selection"))) - <>) - ;; If the tool call was cancelled, set the cancelling flag - ;; to indicate that a cancellation is in progress. - (put (state-session-cancelling? session-id) - (eq? selection 'cancel) - <>) - ;; 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-send-agent-request state request context) - "Return an updated @var{state} and a list of effects sending @var{request} from -the agent to the client. Stash @var{context} against request ID in -@code{requests-alist} for future recall." - (let ((request-id (focus state-agent-request-id state))) - (values (-> state - ;; Register this request so we can recall the details later when - ;; the response comes in. - (push state-requests-alist - (cons request-id - context) - <>) - ;; Bump agent request ID. - (over state-agent-request-id - 1+ - <>)) - ;; Set request ID in request JSON. - (list (if (assoc "id" (focus acp-message-json request)) - ;; The request JSON already has an "id" field; overwrite - ;; it. - (put (compose (key-ref "id") acp-message-json) - request-id - request) - ;; The request JSON has no "id" field; cons it on; - (over acp-message-json - (cut cons - (cons "id" request-id) - <>) - request)))))) - -(define (next-state-tool-call state session-id call-json tools) - "Given current @var{state} and a new tool @var{call-json}, return the next state -and a list of effects. - -@var{tools} is the same as in @code{tea-loop}." - (guard (c ((tool-call-parse-failure? c) - (let ((call-id (focus (key-ref "id") call-json))) - (values (-> state - ;; Push tool call response onto messages. - (push (state-messages session-id) - `(("role" . "tool") - ("tool_call_id" . ,call-id) - ("content" . ,(tool-call-parse-failure-message c))) - <>)) - ;; Notify client about invalid tool call. - (list (acp-message `(("jsonrpc" . "2.0") - ("method" . "session/update") - ("params" - ("sessionId" . ,session-id) - ("update" - ("sessionUpdate" . "tool_call_update") - ("toolCallId" . ,call-id) - ("status" . "failed")))))))))) - (let* ((call (spec->tool-call session-id - (focus (state-cwd session-id) - state) - tools - (focus (state-allowed-tools session-id) - state) - (focus (state-rejected-tools session-id) - state) - call-json)) - (state - ;; Queue tool call. - (push (state-tool-calls session-id) - (cons (tool-call-id call) - call) - state))) - (let-values (((state effects) - (if (eq? (focus tool-call-status call) - 'pending-approval) - ;; Tool call requires permission from the client; - ;; dispatch a request. - (next-state-send-agent-request - state - (acp-message `(("jsonrpc" . "2.0") - ("method" . "session/request_permission") - ("params" - ("sessionId" . ,session-id) - ("toolCall" - ("toolCallId" . ,(tool-call-id call))) - ("options" . - ,(vector %tool-allow-once - %tool-allow-always - %tool-reject-once - %tool-reject-always))))) - call) - ;; Tool call is already pre-approved or pre-rejected; - ;; schedule it. - (values state - (list call))))) - (values state - ;; Notify client about new tool call before other effects. - (cons (let ((tool (focus (key-ref (tool-call-function call)) - tools)) - (args (alist->plist (tool-call-arguments 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" . ,(tool-kind tool)) - ("rawInput" . ,(tool-call-arguments call)) - ("status" . "pending")))))) - effects)))))) - -(define (next-state-llm-response state response tools) - "Given current @var{state} and a new LLM @var{response}, return the next state -and a list of effects. - -@var{tools} is the same as in @code{tea-loop}." - (let* ((session-id (llm-response-session-id response)) - (llm-reply (focus (in-json "choices" 0 "message") - (llm-response-json response))) - (tool-calls-json (cond - ((focus (key-ref "tool_calls") - llm-reply) - => vector->list) - (else '())))) - (let-values (((state tool-call-effects) - (foldn (lambda (call-json state effects) - (let-values (((state new-effects) - (next-state-tool-call - state session-id call-json tools))) - (values state - (append new-effects effects)))) - tool-calls-json - (-> state - ;; Push LLM response onto messages. - (push (state-messages session-id) - llm-reply - <>)) - '()))) - (values state - (cons (agent-message-chunk session-id - ;; Send LLM's text response. - (focus (key-ref "content") - llm-reply)) - (append tool-call-effects - ;; End prompt turn if there are no further tool - ;; calls and a cancellation is not in progress. - (if (and (null? tool-calls-json) - (not (focus (state-session-cancelling? session-id) - state))) - (list (acp-message `(("jsonrpc" . "2.0") - ("id" . ,(focus state-client-request-id - state)) - ("result" - ("stopReason" . "end_turn"))))) - '()) - ;; All tool calls may have been invalid. Maybe - ;; dispatch LLM requests, but only if there were any - ;; in the first place. - (if (not (null? tool-calls-json)) - (state->llm-requests session-id state) - '()))))))) - -(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_update") - ("toolCallId" . ,(tool-call-result-call-id result)) - ("status" . - ,(if (tool-call-result-success? result) - "completed" - "failed")) - ("content" . - ,(vector `(("type" . "content") - ("content" - ("type" . "text") - ("text" . - ,(focus (key-ref "content") - (tool-call-result-json result))))))))))) - (state->llm-requests session-id state))))) - -(define (next-state state message tools) - "Given current @var{state} and a new @var{message}, return the next state and a -list of effects. - -@var{tools} is the same as in @code{tea-loop}." - (cond - ((acp-message? message) - (let ((json-message (focus 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 tools))) - (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 tools)) - ((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 tools))) - ;; 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 (focus 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 deleted file mode 100644 index ef5d7ed..0000000 --- a/kaakaa/tools.scm +++ /dev/null @@ -1,261 +0,0 @@ -;;; 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-call-parse-failure? - tool-call-parse-failure-message - - 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?) - (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 'pending-approval, '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-parse-failure &serious - tool-call-parse-failure tool-call-parse-failure? - (message tool-call-parse-failure-message)) - -(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 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. - -@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. @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 - (tool-call-parse-failure - "Error: Arguments are not valid JSON")))) - (json-string->scm (focus (in "function" "arguments") - spec)))) - (name (focus (in "function" "name") - spec)) - (tool (cond - ((focus (key-ref name) tools) - => identity) - (else - (raise-exception - (tool-call-parse-failure - (string-append "Error: Function " name " does not exist"))))))) - (tool-call session-id - session-cwd - (focus (key-ref "id") - spec) - name - ;; Only pick out valid arguments, and error out if any required - ;; arguments are missing. - (filter-map (match-lambda - ((arg-name . parameter) - (cond - ((assoc arg-name args) - => identity) - (else - (and (tool-parameter-required? parameter) - (raise-exception - (tool-call-parse-failure - (string-append "Error: Missing required argument " - arg-name)))))))) - (tool-parameters tool)) - ;; 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>} -object. @var{tools} is an association list mapping the names of all -available tools to their respective @code{<tool>} objects." - (let ((tool (focus (key-ref (tool-call-function tool-call)) - tools))) - (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 (alist->plist (tool-call-arguments tool-call))) - ;; 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) - args)) - (tool-container-namespaces tool) - (lambda () - (chdir (tool-call-session-cwd tool-call)) - (apply (tool-proc tool) - args))))) - ;; Build result. - (tool-call-result (tool-call-session-id tool-call) - (tool-call-id tool-call) - (apply (tool-title tool) args) - (tool-kind tool) - (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"))))) diff --git a/kaakaa/tools/base.scm b/kaakaa/tools/base.scm deleted file mode 100644 index cbbb6a5..0000000 --- a/kaakaa/tools/base.scm +++ /dev/null @@ -1,225 +0,0 @@ -;;; 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 exceptions) - #:use-module (rnrs io ports) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-171) - #:use-module (ice-9 format) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (kaakaa tools) - #:export (%list-files - %base-tools)) - -(define (binary-file? file) - "Return @code{#t} if @var{file} is a binary file. Else, return @code{#f}." - ;; We use the following heuristic: If there are character decoding errors in - ;; the first 10K characters, we assume that this is a binary file. - (guard (c ((or (i/o-decoding-error? c) - (eq? (exception-kind c) - 'decoding-error)) - #t)) - (call-with-input-file file - (lambda (port) - (set-port-conversion-strategy! port 'error) - (get-string-n port (* 10 1024)))) - #f)) - -(define (make-regexp* pattern) - "Like @code{make-regexp}, but report an error and abort if @var{pattern} is not a -valid regular expression." - (guard (c ((eq? (exception-kind c) - 'regular-expression-syntax) - (format (current-output-port) - "Error: Invalid regular expression: ~s~%" - pattern) - (exit #f))) - (make-regexp pattern))) - -(define (files-recursively directory pattern) - "Return a list of all files recursively down @var{directory} whose basename -matches regular expression @var{pattern}. Hidden directories are not traversed." - (cond - ((not (file-exists? directory)) - (format (current-output-port) - "Error: Directory ~a does not exist~%" - directory) - (exit #f)) - ((not (eq? (stat:type (stat directory)) - 'directory)) - (format (current-output-port) - "Error: ~a is not a directory~%" - directory) - (exit #f)) - (else - (let ((pattern-rx (make-regexp* pattern))) - (file-system-fold (lambda (path stat result) - (not (string-prefix? "." (basename path)))) - (lambda (path stat result) - (if (regexp-exec pattern-rx (basename path)) - (cons path result) - result)) - (lambda (path stat result) - result) - (lambda (path stat result) - result) - (lambda (path stat result) - result) - (lambda (path stat errno result) - (format (current-output-port) - "Error: ~a: ~a~%" - path - (strerror errno)) - result) - (list) - (canonicalize-path directory)))))) - -(define %read - (tool #:description "Read whole text file, or optionally a subset of its lines. - -Line numbers start from 1. Output is the raw file contents without line numbers." - #:parameters `(("path" . ,(tool-parameter - #:type "string" - #:description "File path to read" - #:required? #t)) - ("start-line" . ,(tool-parameter - #:type "integer" - #:description "Read file starting from this line number (inclusive). Default is 1.")) - ("end-line" . ,(tool-parameter - #:type "integer" - #:description "Read up to this line number (inclusive). Default is the last line of the file."))) - #:proc (lambda* (#:key path (start-line 1) end-line) - (cond - ((not (file-exists? path)) - (format (current-output-port) - "Error: File ~a does not exist~%" - path) - (exit #f)) - ((binary-file? path) - (format (current-output-port) - "Error: File ~a is binary, not text~%" - path) - (exit #f)) - (else - (call-with-input-file path - (cut port-transduce - (compose (tdrop (1- start-line)) - (if end-line - (ttake (- end-line (1- start-line))) - (tmap identity)) - (tlog (lambda (result input) - (display input) - (newline)))) - (const #t) - get-line - <>))))) - #:title (lambda* (#:key path (start-line 1) end-line) - (format #f "read ~a:~a-~a" - path start-line (or end-line ""))) - #:kind "read")) - -(define %list - (tool #:description "List files recursively. - -The output is in three columns—the file type, the file size and the file path." - #:parameters `(("root" . ,(tool-parameter - #:type "string" - #:description "Root path to list from" - #:required? #t)) - ("pattern" . ,(tool-parameter - #:type "string" - #:description - "POSIX extended regular expression to match basename (including extension) of -file against. Default matches all files. - -For example, to match all scheme (.scm) files, use \"\\.scm$\""))) - #:proc (lambda* (#:key root (pattern ".")) - (for-each (lambda (path) - (let ((st (stat path))) - (format (current-output-port) - "~a~/~a~/~a~%" - (stat:type st) - (stat:size st) - path))) - (files-recursively root pattern))) - #:title (lambda* (#:key root pattern) - (if pattern - (format #f "list ~s in ~a" pattern root) - (format #f "list ~a" root))) - #:kind "search")) - -(define %search - (tool #:description "Print lines that match a pattern (similar to grep) - -Similar to grep, the output is three colon separated columns—the file path, the -line number and the matching line. Line numbers start from 1." - #:parameters `(("pattern" . ,(tool-parameter - #:type "string" - #:description "POSIX extended regular expression to search for" - #:required? #t)) - ("files-root" . ,(tool-parameter - #:type "string" - #:description "Root path to start search from" - #:required? #t)) - ("files-pattern" . ,(tool-parameter - #:type "string" - #:description - "POSIX extended regular expression to match basename (including extension) of -file against. Default matches all files. - -For example, to match all scheme (.scm) files, use \"\\.scm$\""))) - #:proc (lambda* (#:key pattern files-root (files-pattern ".")) - (let* ((pattern-rx (make-regexp* pattern)) - (line-matcher (match-lambda - ((_ . line) - (regexp-exec pattern-rx line)))) - (make-line-logger (lambda (file) - (match-lambda* - ((result (line-number . line)) - (format (current-output-port) - "~a:~a:~a~%" - file line-number line)))))) - (for-each (lambda (file) - (call-with-input-file file - (cut port-transduce - (compose (tenumerate 1) - (tfilter line-matcher) - (tlog (make-line-logger file))) - (const #t) - get-line - <>))) - (remove binary-file? - (files-recursively files-root files-pattern))))) - #:title (lambda* (#:key pattern files-root files-pattern) - (if files-pattern - (format #f "shortlist files matching ~s in ~a, then search for lines matching ~s" - files-pattern files-root pattern) - (format #f "search for lines matching ~s in files under ~a" - pattern files-root))) - #:kind "search")) - -(define %base-tools - `(("read" . ,%read) - ("list" . ,%list) - ("search" . ,%search))) - -;; TODO: Implement write. diff --git a/kaakaa/utils.scm b/kaakaa/utils.scm deleted file mode 100644 index a922ef2..0000000 --- a/kaakaa/utils.scm +++ /dev/null @@ -1,89 +0,0 @@ -;;; 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 (-> - foldn - 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 (foldn proc lst . inits) - "Apply @var{proc} to the elements of @var{lst} to build a result, and return -that result. @var{proc} may return multiple values, in which case, an equal -number of values are returned. Each @var{proc} call is @code{(proc element -previous ...)} where @code{element} is an element of @var{lst}, and -@code{(previous ...)} is the return from the previous call to @var{proc} or the -given @var{inits} for the first call. For example, - -(foldn (lambda (n sum sum-of-squares) - (values (+ sum n) - (+ sum-of-squares (expt n 2)))) - (iota 10) - 0 0) -=> 45 -=> 285" - (apply values - (fold (lambda (element results) - (call-with-values (cut apply proc element results) list)) - inits - lst))) - -(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)))))))) |