From fe32909d58a59407350043851970cb3004ad351e Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sun, 12 Apr 2026 18:09:49 +0100 Subject: Rename project to kaagum. kaakaa reminds too many Europeans of shit. 😅 --- .guix/kaagum-package.scm | 94 ++++++ .guix/kaakaa-package.scm | 94 ------ Makefile | 14 +- README.md | 12 +- bin/kaagum | 109 +++++++ bin/kaakaa | 109 ------- guix.scm | 2 +- kaagum/config.scm.in | 27 ++ kaagum/container.scm | 50 +++ kaagum/lens.scm | 62 ++++ kaagum/openai.scm | 79 +++++ kaagum/records.scm | 165 ++++++++++ kaagum/tea.scm | 784 +++++++++++++++++++++++++++++++++++++++++++++++ kaagum/tools.scm | 261 ++++++++++++++++ kaagum/tools/base.scm | 225 ++++++++++++++ kaagum/utils.scm | 89 ++++++ kaakaa/config.scm.in | 27 -- kaakaa/container.scm | 50 --- kaakaa/lens.scm | 62 ---- kaakaa/openai.scm | 79 ----- kaakaa/records.scm | 165 ---------- kaakaa/tea.scm | 784 ----------------------------------------------- kaakaa/tools.scm | 261 ---------------- kaakaa/tools/base.scm | 225 -------------- kaakaa/utils.scm | 89 ------ manifest.scm | 4 +- pre-inst-env | 10 +- 27 files changed, 1967 insertions(+), 1965 deletions(-) create mode 100644 .guix/kaagum-package.scm delete mode 100644 .guix/kaakaa-package.scm create mode 100755 bin/kaagum delete mode 100755 bin/kaakaa create mode 100644 kaagum/config.scm.in create mode 100644 kaagum/container.scm create mode 100644 kaagum/lens.scm create mode 100644 kaagum/openai.scm create mode 100644 kaagum/records.scm create mode 100644 kaagum/tea.scm create mode 100644 kaagum/tools.scm create mode 100644 kaagum/tools/base.scm create mode 100644 kaagum/utils.scm delete mode 100644 kaakaa/config.scm.in delete mode 100644 kaakaa/container.scm delete mode 100644 kaakaa/lens.scm delete mode 100644 kaakaa/openai.scm delete mode 100644 kaakaa/records.scm delete mode 100644 kaakaa/tea.scm delete mode 100644 kaakaa/tools.scm delete mode 100644 kaakaa/tools/base.scm delete mode 100644 kaakaa/utils.scm diff --git a/.guix/kaagum-package.scm b/.guix/kaagum-package.scm new file mode 100644 index 0000000..2145977 --- /dev/null +++ b/.guix/kaagum-package.scm @@ -0,0 +1,94 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum-package) + #:use-module ((gnu packages guile) + #:select (guile-3.0 guile-json-4)) + #:use-module ((gnu packages guile-xyz) + #:select (guile-lens guile-run64)) + #:use-module ((gnu packages package-management) + #:select (guix)) + #:use-module (guix build-system gnu) + #:use-module (guix gexp) + #:use-module (guix git-download) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix packages) + #:use-module (guix utils)) + +(define-public kaagum + (package + (name "kaagum") + (version "0.1.0") + (source (local-file ".." + "kaagum-checkout" + #:recursive? #t + #:select? (or (git-predicate (dirname (current-source-directory))) + (const #t)))) + (build-system gnu-build-system) + (arguments + (list #:make-flags + #~(list (string-append "prefix=" #$output)) + #:modules `(((guix build guile-build-system) + #:select (target-guile-effective-version)) + ,@%default-gnu-imported-modules) + #:phases + (with-imported-modules `((guix build guile-build-system) + ,@%default-gnu-imported-modules) + #~(modify-phases %standard-phases + (replace 'patch-source-shebangs + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "bin/kaagum" + (("^exec guile") + (string-append "exec " + (search-input-file inputs "/bin/guile")))))) + (delete 'configure) + (add-after 'install 'wrap + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (effective-version (target-guile-effective-version))) + (wrap-program (string-append out "/bin/kaagum") + `("GUILE_LOAD_PATH" prefix + (,(string-append out "/share/guile/site/" effective-version) + ,(getenv "GUILE_LOAD_PATH"))) + `("GUILE_LOAD_COMPILED_PATH" prefix + (,(string-append out "/lib/guile/" + effective-version "/site-ccache") + ,(getenv "GUILE_LOAD_COMPILED_PATH"))))))))))) + (inputs + (list guile-3.0 guile-json-4 guile-lens guix)) + (native-inputs + (list guile-run64)) + (home-page "https://forge.systemreboot.net/kaagum") + (synopsis "Tiny, security-focused AI agent in Guile") + (description + "kaagum is a tiny, security-focused AI agent written in Guile with +minimal dependencies. Kaagum works with any LLM that provides an +OpenAI-compatible API. + +kaagum runs tool calls securely using containers and capability-based +access. Tool calls have limited or no access to the filesystem and to +the network. Capabilities allow network access to be controlled with +fine granularity. Containers are implemented using Guix's container +API. + +kaagum offers no user interface on its own. Instead, it speaks +the @acronym{ACP, Agent Client Protocol} and allows you to use any +compatible user interface of your choice.") + (license license:gpl3+))) + +kaagum diff --git a/.guix/kaakaa-package.scm b/.guix/kaakaa-package.scm deleted file mode 100644 index f3f0136..0000000 --- a/.guix/kaakaa-package.scm +++ /dev/null @@ -1,94 +0,0 @@ -;;; kaakaa --- Tiny, security-focused AI agent in Guile -;;; Copyright © 2026 Arun Isaac -;;; -;;; 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 . - -(define-module (kaakaa-package) - #:use-module ((gnu packages guile) - #:select (guile-3.0 guile-json-4)) - #:use-module ((gnu packages guile-xyz) - #:select (guile-lens guile-run64)) - #:use-module ((gnu packages package-management) - #:select (guix)) - #:use-module (guix build-system gnu) - #:use-module (guix gexp) - #:use-module (guix git-download) - #:use-module ((guix licenses) #:prefix license:) - #:use-module (guix packages) - #:use-module (guix utils)) - -(define-public kaakaa - (package - (name "kaakaa") - (version "0.1.0") - (source (local-file ".." - "kaakaa-checkout" - #:recursive? #t - #:select? (or (git-predicate (dirname (current-source-directory))) - (const #t)))) - (build-system gnu-build-system) - (arguments - (list #:make-flags - #~(list (string-append "prefix=" #$output)) - #:modules `(((guix build guile-build-system) - #:select (target-guile-effective-version)) - ,@%default-gnu-imported-modules) - #:phases - (with-imported-modules `((guix build guile-build-system) - ,@%default-gnu-imported-modules) - #~(modify-phases %standard-phases - (replace 'patch-source-shebangs - (lambda* (#:key inputs #:allow-other-keys) - (substitute* "bin/kaakaa" - (("^exec guile") - (string-append "exec " - (search-input-file inputs "/bin/guile")))))) - (delete 'configure) - (add-after 'install 'wrap - (lambda* (#:key inputs outputs #:allow-other-keys) - (let ((out (assoc-ref outputs "out")) - (effective-version (target-guile-effective-version))) - (wrap-program (string-append out "/bin/kaakaa") - `("GUILE_LOAD_PATH" prefix - (,(string-append out "/share/guile/site/" effective-version) - ,(getenv "GUILE_LOAD_PATH"))) - `("GUILE_LOAD_COMPILED_PATH" prefix - (,(string-append out "/lib/guile/" - effective-version "/site-ccache") - ,(getenv "GUILE_LOAD_COMPILED_PATH"))))))))))) - (inputs - (list guile-3.0 guile-json-4 guile-lens guix)) - (native-inputs - (list guile-run64)) - (home-page "https://forge.systemreboot.net/kaakaa") - (synopsis "Tiny, security-focused AI agent in Guile") - (description - "kaakaa is a tiny, security-focused AI agent written in Guile with -minimal dependencies. Kaakaa works with any LLM that provides an -OpenAI-compatible API. - -kaakaa runs tool calls securely using containers and capability-based -access. Tool calls have limited or no access to the filesystem and to -the network. Capabilities allow network access to be controlled with -fine granularity. Containers are implemented using Guix's container -API. - -kaakaa offers no user interface on its own. Instead, it speaks -the @acronym{ACP, Agent Client Protocol} and allows you to use any -compatible user interface of your choice.") - (license license:gpl3+))) - -kaakaa diff --git a/Makefile b/Makefile index 39d49a2..777b274 100644 --- a/Makefile +++ b/Makefile @@ -1,22 +1,22 @@ -# kaakaa --- Tiny, security-focused AI agent in Guile +# kaagum --- Tiny, security-focused AI agent in Guile # Copyright © 2026 Arun Isaac # -# This file is part of kaakaa. +# This file is part of kaagum. # -# kaakaa is free software: you can redistribute it and/or modify it +# kaagum 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 +# kaagum 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 . +# along with kaagum. If not, see . -project = kaakaa +project = kaagum version = 0.1.0 GIT = git @@ -45,7 +45,7 @@ scripts = $(wildcard bin/*) tests = $(wildcard tests/*.scm) distribute_files = $(sources) $(config_file_template) $(scripts) \ $(tests) pre-inst-env guix.scm \ - .guix/kaakaa-package.scm Makefile \ + .guix/kaagum-package.scm Makefile \ COPYING README.md scmdir = $(datarootdir)/guile/site/$(guile_effective_version) diff --git a/README.md b/README.md index cda6c09..06904ac 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -kaakaa (pronounced kah-kah) is a tiny, security-focused AI agent written in Guile with minimal dependencies. Kaakaa works with any LLM that provides an OpenAI-compatible API. +kaagum (pronounced kah-kah) is a tiny, security-focused AI agent written in Guile with minimal dependencies. Kaagum works with any LLM that provides an OpenAI-compatible API. -kaakaa runs tool calls securely using containers and capability-based access. Tool calls have limited or no access to the filesystem and to the network. Capabilities allow network access to be controlled with fine granularity. Containers are implemented using Guix's container API. +kaagum runs tool calls securely using containers and capability-based access. Tool calls have limited or no access to the filesystem and to the network. Capabilities allow network access to be controlled with fine granularity. Containers are implemented using Guix's container API. -Kaakaa offers no user interface on its own. Instead, it speaks the [Agent Client Protocol (ACP)](https://agentclientprotocol.com/) and allows you to use any compatible user interface of your choice. +Kaagum offers no user interface on its own. Instead, it speaks the [Agent Client Protocol (ACP)](https://agentclientprotocol.com/) and allows you to use any compatible user interface of your choice. # Author's note on AI use @@ -18,8 +18,10 @@ Despite being an AI agent, all code in this project is lovingly hand-crafted. I # License -kaakaa is free software released under the terms of the [GNU General Public License](https://www.gnu.org/licenses/gpl.html), either version 3 of the License, or (at your option) any later version. +kaagum is free software released under the terms of the [GNU General Public License](https://www.gnu.org/licenses/gpl.html), either version 3 of the License, or (at your option) any later version. # The Name -kaakaa (காக்கா—pronounced kah-kah) means "crow" 🐦‍⬛ in Tamil. It also evokes "kaaka" (காக்க—pronounced kah-kuh), meaning "to protect". Crows are intelligent birds, and kaakaa protects you from reckless/malicious tool use by LLMs. +kaagum (காகம்—pronounced kah-gum) means "crow" 🐦‍⬛ in Tamil. It also evokes "kaa" (கா—pronounced kah), a verb that means "to protect". Crows are intelligent birds, and kaagum protects you from reckless/malicious tool use by LLMs. + +In colloquial Tamil, crows are also called "kaakaa"—which is similar to the word for shit in many European languages. Just a gentle reminder that LLMs, despite how intelligent they sometimes seem, often produce shitty code—rather like the crows that bombard you with aerial excrement when you least expect it. diff --git a/bin/kaagum b/bin/kaagum new file mode 100755 index 0000000..4b9ab9f --- /dev/null +++ b/bin/kaagum @@ -0,0 +1,109 @@ +#!/usr/bin/env sh +# -*- mode: scheme; -*- +exec guile --no-auto-compile -e main -s "$0" "$@" +!# +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(use-modules (rnrs io ports) + (srfi srfi-37) + (ice-9 match) + (kaagum config) + (kaagum openai) + (kaagum tea) + (kaagum tools base) + (kaagum utils)) + +(define (invalid-option opt name arg result) + (error "Invalid option" name)) + +(define (invalid-argument arg result) + (error "Invalid argument" arg)) + +(define %options + (list (option (list #\m "model") #t #f + (lambda (opt name arg result) + (acons 'model arg + result))) + (option (list #\a "api-base-uri") #t #f + (lambda (opt name arg result) + (acons 'api-base-uri arg result))) + (option (list #\k "api-key-command") #t #f + (lambda (opt name arg result) + (acons 'api-key-command arg result))) + (option (list #\v "version") #f #f + (lambda (opt name arg result) + (acons 'version #t result))) + (option (list #\h "help") #f #f + (lambda (opt name arg result) + (acons 'help #t result))))) + +(define (print-usage program) + "Print kaagum usage. @var{program} is the name of the executable used +to invoke kaagum." + (format (current-error-port) + "Usage: ~a [OPTIONS] +Run kaagum AI agent. + + --api-base-uri=URI base API URI of LLM provider + --api-key-command=COMMAND command to run to get API key + --model=MODEL LLM model name + + --version print version and exit + --help print this help and exit +" + program)) + +(define (die fmt . args) + "Print formatted message, followed by a newline and exit with failure." + (apply format (current-error-port) fmt args) + (newline (current-error-port)) + (exit #f)) + +(define (get-api-key api-key-command) + "Run @var{api-key-command} and get the API key." + ;; We use a shell to execute since + ;; 1. api-key-command is a string, not a list of string arguments + ;; 2. api-key-command may contain pipes + (call-with-input-pipe `("sh" "-c" ,api-key-command) + get-string-all)) + +(define main + (match-lambda + ((program args ...) + (let ((args (args-fold args + %options + invalid-option + invalid-argument + '((model . "anthropic/claude-opus-4.6") + (api-base-uri . "https://openrouter.ai"))))) + (when (assq-ref args 'help) + (print-usage program) + (exit #t)) + (when (assq-ref args 'version) + (format (current-output-port) + "~a ~a~%" + %project %version) + (exit #t)) + (unless (assq-ref args 'api-key-command) + (die "--api-key-command not specified")) + (tea-loop (initial-state) + (assq-ref args 'api-base-uri) + (get-api-key (assq-ref args 'api-key-command)) + (assq-ref args 'model) + %base-tools))))) diff --git a/bin/kaakaa b/bin/kaakaa deleted file mode 100755 index 5f94176..0000000 --- a/bin/kaakaa +++ /dev/null @@ -1,109 +0,0 @@ -#!/usr/bin/env sh -# -*- mode: scheme; -*- -exec guile --no-auto-compile -e main -s "$0" "$@" -!# -;;; kaakaa --- Tiny, security-focused AI agent in Guile -;;; Copyright © 2026 Arun Isaac -;;; -;;; 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 . - -(use-modules (rnrs io ports) - (srfi srfi-37) - (ice-9 match) - (kaakaa config) - (kaakaa openai) - (kaakaa tea) - (kaakaa tools base) - (kaakaa utils)) - -(define (invalid-option opt name arg result) - (error "Invalid option" name)) - -(define (invalid-argument arg result) - (error "Invalid argument" arg)) - -(define %options - (list (option (list #\m "model") #t #f - (lambda (opt name arg result) - (acons 'model arg - result))) - (option (list #\a "api-base-uri") #t #f - (lambda (opt name arg result) - (acons 'api-base-uri arg result))) - (option (list #\k "api-key-command") #t #f - (lambda (opt name arg result) - (acons 'api-key-command arg result))) - (option (list #\v "version") #f #f - (lambda (opt name arg result) - (acons 'version #t result))) - (option (list #\h "help") #f #f - (lambda (opt name arg result) - (acons 'help #t result))))) - -(define (print-usage program) - "Print kaakaa usage. @var{program} is the name of the executable used -to invoke kaakaa." - (format (current-error-port) - "Usage: ~a [OPTIONS] -Run kaakaa AI agent. - - --api-base-uri=URI base API URI of LLM provider - --api-key-command=COMMAND command to run to get API key - --model=MODEL LLM model name - - --version print version and exit - --help print this help and exit -" - program)) - -(define (die fmt . args) - "Print formatted message, followed by a newline and exit with failure." - (apply format (current-error-port) fmt args) - (newline (current-error-port)) - (exit #f)) - -(define (get-api-key api-key-command) - "Run @var{api-key-command} and get the API key." - ;; We use a shell to execute since - ;; 1. api-key-command is a string, not a list of string arguments - ;; 2. api-key-command may contain pipes - (call-with-input-pipe `("sh" "-c" ,api-key-command) - get-string-all)) - -(define main - (match-lambda - ((program args ...) - (let ((args (args-fold args - %options - invalid-option - invalid-argument - '((model . "anthropic/claude-opus-4.6") - (api-base-uri . "https://openrouter.ai"))))) - (when (assq-ref args 'help) - (print-usage program) - (exit #t)) - (when (assq-ref args 'version) - (format (current-output-port) - "~a ~a~%" - %project %version) - (exit #t)) - (unless (assq-ref args 'api-key-command) - (die "--api-key-command not specified")) - (tea-loop (initial-state) - (assq-ref args 'api-base-uri) - (get-api-key (assq-ref args 'api-key-command)) - (assq-ref args 'model) - %base-tools))))) diff --git a/guix.scm b/guix.scm index f9a22d9..3026f78 120000 --- a/guix.scm +++ b/guix.scm @@ -1 +1 @@ -.guix/kaakaa-package.scm \ No newline at end of file +.guix/kaagum-package.scm \ No newline at end of file diff --git a/kaagum/config.scm.in b/kaagum/config.scm.in new file mode 100644 index 0000000..2c662d3 --- /dev/null +++ b/kaagum/config.scm.in @@ -0,0 +1,27 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum config) + #:export (%project + %version)) + +(define %project + "@PROJECT@") + +(define %version + "@VERSION@") diff --git a/kaagum/container.scm b/kaagum/container.scm new file mode 100644 index 0000000..f0a0c04 --- /dev/null +++ b/kaagum/container.scm @@ -0,0 +1,50 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum container) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (gnu build linux-container) + #:use-module (guix utils) + #:use-module (kaagum records) + #:export (call-with-container*)) + +(define-public-record-type* ( 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{} 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/kaagum/lens.scm b/kaagum/lens.scm new file mode 100644 index 0000000..6739244 --- /dev/null +++ b/kaagum/lens.scm @@ -0,0 +1,62 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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/kaagum/openai.scm b/kaagum/openai.scm new file mode 100644 index 0000000..64bda72 --- /dev/null +++ b/kaagum/openai.scm @@ -0,0 +1,79 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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/kaagum/records.scm b/kaagum/records.scm new file mode 100644 index 0000000..997f96b --- /dev/null +++ b/kaagum/records.scm @@ -0,0 +1,165 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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?) + (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?) + (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/kaagum/tea.scm b/kaagum/tea.scm new file mode 100644 index 0000000..18bae8d --- /dev/null +++ b/kaagum/tea.scm @@ -0,0 +1,784 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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 (kaagum lens) + #:use-module (kaagum openai) + #:use-module (kaagum records) + #:use-module (kaagum tools) + #:use-module (kaagum 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?) + (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?) + (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{} 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?) + (fields (session-id llm-request-session-id) + (messages llm-request-messages))) + +(define-record-type* ( llm-response llm-response?) + (fields (session-id llm-response-session-id) + (json llm-response-json))) + +(define-record-type* ( acp-message acp-message?) + (fields (json acp-message-json lensed))) + +(define-record-type* ( 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" . "kaagum") + ("title" . "Kaagum") + ("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{} 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/kaagum/tools.scm b/kaagum/tools.scm new file mode 100644 index 0000000..f561e65 --- /dev/null +++ b/kaagum/tools.scm @@ -0,0 +1,261 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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 (kaagum container) + #:use-module (kaagum records) + #:use-module (kaagum 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?) + (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 + ;; 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?) + (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?) + (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?) + (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?) + (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{} +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{} +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{} +object. @var{tools} is an association list mapping the names of all +available tools to their respective @code{} 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/kaagum/tools/base.scm b/kaagum/tools/base.scm new file mode 100644 index 0000000..87a4688 --- /dev/null +++ b/kaagum/tools/base.scm @@ -0,0 +1,225 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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 (kaagum 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/kaagum/utils.scm b/kaagum/utils.scm new file mode 100644 index 0000000..b6292c1 --- /dev/null +++ b/kaagum/utils.scm @@ -0,0 +1,89 @@ +;;; kaagum --- Tiny, security-focused AI agent in Guile +;;; Copyright © 2026 Arun Isaac +;;; +;;; This file is part of kaagum. +;;; +;;; kaagum 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. +;;; +;;; kaagum 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 kaagum. If not, see . + +(define-module (kaagum 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)))))))) 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 -;;; -;;; 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 . - -(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 -;;; -;;; 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 . - -(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?) - (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{} 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 -;;; -;;; 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 . - -(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 -;;; -;;; 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 . - -(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 -;;; -;;; 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 . - -(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?) - (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?) - (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 -;;; -;;; 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 . - -(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?) - (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?) - (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{} 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?) - (fields (session-id llm-request-session-id) - (messages llm-request-messages))) - -(define-record-type* ( llm-response llm-response?) - (fields (session-id llm-response-session-id) - (json llm-response-json))) - -(define-record-type* ( acp-message acp-message?) - (fields (json acp-message-json lensed))) - -(define-record-type* ( 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{} 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 -;;; -;;; 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 . - -(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?) - (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 - ;; 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?) - (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?) - (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?) - (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?) - (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{} -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{} -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{} -object. @var{tools} is an association list mapping the names of all -available tools to their respective @code{} 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 -;;; -;;; 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 . - -(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 -;;; -;;; 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 . - -(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)))))))) diff --git a/manifest.scm b/manifest.scm index f0fe58e..22c104d 100644 --- a/manifest.scm +++ b/manifest.scm @@ -1,6 +1,6 @@ (use-modules ((gnu packages guile-xyz) #:select (guile-ares-rs)) ((gnu packages task-management) #:select (git-bug)) - ((kaakaa-package) #:select (kaakaa)) + ((kaagum-package) #:select (kaagum)) (srfi srfi-1)) (define (manifest-cons* . args) @@ -13,4 +13,4 @@ with PACKAGES and all packages in ONTO-MANIFEST." (manifest-cons* git-bug guile-ares-rs - (package->development-manifest kaakaa)) + (package->development-manifest kaagum)) diff --git a/pre-inst-env b/pre-inst-env index b01b5ed..eb28371 100755 --- a/pre-inst-env +++ b/pre-inst-env @@ -1,22 +1,22 @@ #! /usr/bin/env guile !# -;;; kaakaa --- Tiny, security-focused AI agent in Guile +;;; kaagum --- Tiny, security-focused AI agent in Guile ;;; Copyright © 2026 Arun Isaac ;;; -;;; This file is part of kaakaa. +;;; This file is part of kaagum. ;;; -;;; kaakaa is free software: you can redistribute it and/or modify it +;;; kaagum 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 +;;; kaagum 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 . +;;; along with kaagum. If not, see . (use-modules (ice-9 match)) -- cgit 1.4.1