Compare commits
315 Commits
v0.2.1
...
084abc0644
| Author | SHA1 | Date | |
|---|---|---|---|
| 084abc0644 | |||
| a64532bc96 | |||
| e763768122 | |||
| 0629f8c6d3 | |||
| 9492e00318 | |||
| ef36854822 | |||
| 8dd94f6d3c | |||
| 8eb866dee3 | |||
| b61191bec2 | |||
| f783b45ac7 | |||
| ab8ffb6a64 | |||
| fd99099258 | |||
| d157a837a9 | |||
| 126e104854 | |||
| 5c4edb3d98 | |||
| 7eab3c93d2 | |||
| 2f1abee930 | |||
| 1427e662e2 | |||
| 8c29c228cd | |||
| a65374e120 | |||
| 46cac554ab | |||
| b1aafc56b2 | |||
| 05aec4d028 | |||
| 2c6e38f32d | |||
| 53ca5af17e | |||
| 20cfe2a75b | |||
| 4b0034c1a5 | |||
| 5797e43cd8 | |||
| 5524b4de06 | |||
| 73d42a812a | |||
| e04b12c31c | |||
| 2fedbbcb3b | |||
| c568ac6842 | |||
| aca3f9e314 | |||
| 5444322bf9 | |||
| f8ae4ac817 | |||
| 7eca785b0a | |||
| 7e9da0f867 | |||
| bb98b486e4 | |||
| bcab429dd7 | |||
| 2513466576 | |||
| f6dbd6dbd0 | |||
| bad7686d4e | |||
| 2189745f40 | |||
| 0a0478f502 | |||
| 3bc1977632 | |||
| 13b6edab32 | |||
| 8d9520a9cb | |||
| bd72175d5b | |||
| cc38e67d7c | |||
| df33e8d6db | |||
| bd1e8a92be | |||
| 9fb4393c9c | |||
| c1f4ad40d2 | |||
| d14ff3a316 | |||
| 5924994202 | |||
| 53aa471a51 | |||
| c148570d4c | |||
| f56ff4849f | |||
| 3661d00138 | |||
| 25da9ae685 | |||
| 6d7dd9e1ea | |||
| e453f9aad9 | |||
| 74621cffd2 | |||
| 2ce8d9d886 | |||
| 345f3f397d | |||
| 84ef4c3443 | |||
| ad5b9669a6 | |||
| 187ec6e471 | |||
| 48c2d57c14 | |||
| b2f5f1cf1a | |||
| 369a7c93a9 | |||
| d1359eba1d | |||
| 4006a62e53 | |||
| a609232589 | |||
| e0003a5f3c | |||
| 14cdb6c7b4 | |||
| d71ccb95c6 | |||
| 55166fc9ff | |||
| f5fdfe73d6 | |||
| b6ceb2525a | |||
| 337b8cdd86 | |||
| c4c1629816 | |||
| 7cb43a953d | |||
| 39a9a3d7f2 | |||
| 4bfb407094 | |||
| d5b4c8c8f0 | |||
| c0d0ddfeec | |||
| b9a4318ef8 | |||
| 0ad9d3bdb5 | |||
| a8f8d841a4 | |||
| ec38589237 | |||
| 21d054bc38 | |||
| adca69d29c | |||
| 1884372660 | |||
| 11cb466d4f | |||
| 226f979d38 | |||
| a9705253a5 | |||
| ce3e8ed44c | |||
| 7d3dc479eb | |||
| 35fbf1d418 | |||
| b17c501231 | |||
| 15d16fd520 | |||
| e27cffa4e0 | |||
| b5a07a5dcb | |||
| 60ce9c894c | |||
| 36e7d51fce | |||
| af4d81ec9f | |||
| 79896c5ffd | |||
| 4b60e8c544 | |||
| 885fc3f92e | |||
| 6e69c4a724 | |||
| 761678bbd6 | |||
| 2d18fa4525 | |||
| f8d56cdeba | |||
| 00211cf685 | |||
| a8901d9675 | |||
| c227877302 | |||
| 8fd56dece3 | |||
| 27d203ad67 | |||
| 2ac87b626a | |||
|
|
d77d41f3a8 | ||
| 138f909a33 | |||
| b3ce9056de | |||
| 1201b916d8 | |||
| f7b3e20a15 | |||
| da5718b97c | |||
| 8aed017ccd | |||
| 4e756aeaa1 | |||
| d67c4022f7 | |||
| 49eec4b8ae | |||
| 06aff97b4e | |||
| 93a38d5308 | |||
| 7c84dbfacb | |||
| 7fca4189b9 | |||
| 4bd387e256 | |||
| 510643786b | |||
| 44f927e8f1 | |||
| 029a32ef64 | |||
| c959f93eb1 | |||
| 2e52bc4d13 | |||
| 19a9c99ef4 | |||
| 96370cc4b1 | |||
| 11c43f76fa | |||
| df09ac321d | |||
| 4e87cf6a03 | |||
| e3a6573542 | |||
| ca44136a55 | |||
| 26fd756222 | |||
| d2d61c5b44 | |||
| bec894ca4f | |||
| b40e1e2844 | |||
| 22878be710 | |||
| e3e62140ff | |||
| fa95e7fb62 | |||
| e05d23f34e | |||
| 6aab95e0c3 | |||
| fbed26f434 | |||
| f508dec080 | |||
| 30913bf327 | |||
| c8964d0249 | |||
| ce715b599c | |||
| 55e0c962f4 | |||
| 66df5b493a | |||
| 72f032fd67 | |||
| b6858707bc | |||
| 0c22505970 | |||
| deae08ab44 | |||
| 19a8b66ef9 | |||
| 04c219468d | |||
| f6079246ee | |||
| c86d079418 | |||
| 0b1fbc36bb | |||
| 429abedb5a | |||
| 924bf8f479 | |||
| da160b71e3 | |||
| eeb1234086 | |||
| 791a0f9c3b | |||
| 639bc348d9 | |||
| d3b74f5c88 | |||
| 52a8386282 | |||
| f28363dc45 | |||
| a593b76015 | |||
| cd752bb4ad | |||
| c7e9893e68 | |||
| 7431121d42 | |||
| f6a70faffc | |||
| 0857a8a1db | |||
| c2e14a1268 | |||
| 98087b43c5 | |||
| 0e8ba36ddb | |||
| 55e27f5194 | |||
| a0f7bd7671 | |||
| 385a6497ac | |||
| 11254b56ec | |||
| 33993d2d73 | |||
| ae994fa452 | |||
| 9350cb855e | |||
| 0861ac26f1 | |||
| 4bed6dd461 | |||
| a31f19045a | |||
| d50d72656c | |||
| 9d591c85f1 | |||
| 15afa2bb52 | |||
| 42e07801ce | |||
| 1d91fcc6cc | |||
| 9e451841ce | |||
| 0b16c4829f | |||
| 39b6bef6e0 | |||
| 9130e08e92 | |||
| 183aeeedb8 | |||
| 1f8b821287 | |||
| 7d7a4be668 | |||
| 7c9cc629a1 | |||
| 750918527d | |||
| 9362c56678 | |||
| 26bfce61f1 | |||
| adea3714a7 | |||
| 712717a20c | |||
| ca70a61338 | |||
| 717d63d84a | |||
| 61ea5767d6 | |||
| cd86509e3a | |||
| 035aac45e3 | |||
| 299d501c88 | |||
| a2ede2dd89 | |||
| 23b8cfacd3 | |||
| 9281e37c01 | |||
| ad8242fee6 | |||
| 3d237e9c78 | |||
| 26d917dbc4 | |||
| 057bf9f3a8 | |||
| e0ff6a7563 | |||
| 7a455279b9 | |||
| a34b598858 | |||
| dcb5a1f1a6 | |||
| ea1150f38e | |||
| e5440487d4 | |||
| cfeb4e192c | |||
| 9dd0ed2f78 | |||
| 817d1c5fec | |||
| 11383a29d4 | |||
| 94b939f61a | |||
| d782f58291 | |||
| d8929aeb24 | |||
| 78705f55ec | |||
| f9ae84ba88 | |||
| a437b9c0df | |||
| 1456e59f7f | |||
| 740ff3bb89 | |||
| be6e14a62e | |||
| 54ce3713cd | |||
| cbbf409059 | |||
| 3c1ed77c85 | |||
| 9d7942dc1c | |||
| 8a7259c5c8 | |||
| d1951668cc | |||
| 1b4d147170 | |||
| 5ab54091c1 | |||
| 619407c6e6 | |||
| eb99847ccd | |||
| abfb7e5cf8 | |||
| 02e0c21f06 | |||
| 2e19db80ce | |||
| 31e53e675e | |||
| 3bb797ab9e | |||
| ef4ea1db1b | |||
| 908936d4d3 | |||
| 7dad50910f | |||
| 59fef20630 | |||
| 7393e69397 | |||
| 3c3557f519 | |||
| b728f73ded | |||
| ff64556924 | |||
| f27ab1f779 | |||
| d51e85bc9d | |||
| 9799b9db74 | |||
| b4150a9771 | |||
| 5d93f201be | |||
| a27a3d02b0 | |||
| 4ee85f3df0 | |||
| aedcfeda9f | |||
| 2af882852c | |||
| 4e5428bed0 | |||
| e5723cfd7f | |||
| ee81fa2755 | |||
| c2d3abe265 | |||
| e31ebb394c | |||
| b27ac4cd7f | |||
| deb30d25a9 | |||
| ce90fd3e72 | |||
| a16f973b50 | |||
| 3f51a772d4 | |||
| bbc5e4d8bf | |||
| e0a47575e9 | |||
| a77580c449 | |||
| 5e7b1cee33 | |||
| 231c3bb445 | |||
| 70c9a8775c | |||
| 529f8d0782 | |||
| 22697baa2d | |||
| 9151f4eff7 | |||
| a027e9d984 | |||
| b67cd12d88 | |||
| 836c9ba7b8 | |||
| ec882f87fb | |||
| 5a0d1b1c38 | |||
| 299f72c2bb | |||
| dd478d8a7b | |||
| e2fde5914e | |||
| 0760dc8012 | |||
| 227ad81b30 | |||
| b6923d5584 | |||
| d35aea391e | |||
| 95d1ea3fed |
54
.env.example
54
.env.example
@@ -1,4 +1,4 @@
|
||||
# opencortex: Environment Configuration Template
|
||||
# passepartout: Environment Configuration Template
|
||||
# Copy this to .env and fill in your values
|
||||
|
||||
# =============================================================================
|
||||
@@ -15,23 +15,29 @@ OPENAI_API_KEY="your_openai_key_here"
|
||||
ANTHROPIC_API_KEY="your_anthropic_key_here"
|
||||
GROQ_API_KEY="your_groq_api_key_here"
|
||||
GEMINI_API_KEY="your_gemini_key_here"
|
||||
DEEPSEEK_API_KEY="your_deepseek_key_here"
|
||||
NVIDIA_API_KEY="your_nvidia_nim_key_here"
|
||||
|
||||
# Cascade order (first available provider wins)
|
||||
PROVIDER_CASCADE="openrouter,openai,anthropic,groq,gemini-api,ollama"
|
||||
# Default (if unset): openrouter,openai,anthropic,groq,gemini-api,deepseek,nvidia
|
||||
PROVIDER_CASCADE=deepseek,openrouter,openai,anthropic,groq,gemini,nvidia
|
||||
|
||||
# =============================================================================
|
||||
# LOCAL LLM (Ollama - runs offline)
|
||||
# LOCAL LLM (generic OpenAI-compatible endpoint)
|
||||
# =============================================================================
|
||||
# Set this to the base URL of any local OpenAI-compatible server
|
||||
# (llama.cpp, Ollama, vLLM, LM Studio, etc.)
|
||||
LOCAL_BASE_URL="localhost:8080"
|
||||
|
||||
# Ollama host (legacy: falls back to LOCAL_BASE_URL if not set)
|
||||
OLLAMA_HOST="localhost:11434"
|
||||
|
||||
# llama.cpp backend (for local GGUF models)
|
||||
LLAMA_HOST="localhost:8080"
|
||||
|
||||
# =============================================================================
|
||||
# VECTOR EMBEDDINGS (semantic search)
|
||||
# =============================================================================
|
||||
EMBEDDING_PROVIDER="ollama" # "ollama" or "llama.cpp"
|
||||
EMBEDDING_PROVIDER="hashing" # "hashing" (local, no deps), "local", or "openai"
|
||||
EMBEDDING_MODEL="nomic-embed-text" # model name for embeddings
|
||||
EMBEDDING_BASE_URL="https://api.openai.com/v1" # for :openai provider
|
||||
|
||||
# =============================================================================
|
||||
# MESSAGING GATEWAYS (optional)
|
||||
@@ -52,7 +58,6 @@ SILENT_ACTUATORS="cli,system-message,emacs"
|
||||
# =============================================================================
|
||||
# SECURITY
|
||||
# =============================================================================
|
||||
SAFETY_BLOCK_SHELL=true
|
||||
PROTOCOL_ENFORCE_HMAC=false
|
||||
PROTOCOL_HMAC_SECRET="change-this-to-a-secure-random-string"
|
||||
|
||||
@@ -61,10 +66,19 @@ PROTOCOL_HMAC_SECRET="change-this-to-a-secure-random-string"
|
||||
# Default: @personal
|
||||
PRIVACY_FILTER_TAGS="@personal,@health,@finance"
|
||||
|
||||
# =============================================================================
|
||||
# DISPATCHER RULE LEARNING
|
||||
# =============================================================================
|
||||
# Number of HITL approvals before a pattern becomes a permanent rule
|
||||
DISPATCHER_RULE_THRESHOLD=3
|
||||
|
||||
# Where learned rules are persisted
|
||||
RULES_FILE="$HOME/memex/system/rules.org"
|
||||
|
||||
# =============================================================================
|
||||
# BOOTSTRAP
|
||||
# =============================================================================
|
||||
MANDATORY_SKILLS="org-skill-policy,org-skill-bouncer"
|
||||
MANDATORY_SKILLS="security-policy,security-dispatcher"
|
||||
|
||||
# =============================================================================
|
||||
# CONTEXT / MEMORY
|
||||
@@ -84,3 +98,25 @@ AREAS_DIR="$HOME/memex/areas"
|
||||
RESOURCES_DIR="$HOME/memex/resources"
|
||||
ARCHIVES_DIR="$HOME/memex/archives"
|
||||
SYSTEM_DIR="$HOME/memex/system"
|
||||
LLM_REQUEST_TIMEOUT=30
|
||||
|
||||
# =============================================================================
|
||||
# TOKEN ECONOMICS (v0.5.0)
|
||||
# =============================================================================
|
||||
# Max tokens for the combined system prompt + context + user prompt.
|
||||
# Default: 16384 (half of a 32K context window, leaves room for model response).
|
||||
CONTEXT_MAX_TOKENS=16384
|
||||
|
||||
# Soft daily cost cap in USD. Warning injected into system prompt when
|
||||
# approaching budget.
|
||||
COST_BUDGET_DAILY=1.00
|
||||
|
||||
# v0.7.2: Privacy tag severity tiers. Format: @tag:block,@tag:warn,@tag:log
|
||||
# :block = filter content, :warn = log+allow, :log = silently record
|
||||
# Default: empty (no tags configured)
|
||||
#TAG_CATEGORIES=@personal:block,@financial:block,@draft:warn
|
||||
|
||||
# v0.7.2: Self-build core file protection mode
|
||||
# When true, writes to core-*.org and core-*.lisp require HITL approval.
|
||||
# Default: false (unrestricted — use during development)
|
||||
SELF_BUILD_MODE=false
|
||||
|
||||
@@ -19,6 +19,6 @@ jobs:
|
||||
- name: Build and deploy via Docker Compose
|
||||
run: |
|
||||
cd infrastructure/docker
|
||||
docker-compose -p opencortex down
|
||||
docker-compose -p opencortex build --no-cache opencortex
|
||||
docker-compose -p opencortex up -d --force-recreate opencortex
|
||||
docker-compose -p passepartout down
|
||||
docker-compose -p passepartout build --no-cache passepartout
|
||||
docker-compose -p passepartout up -d --force-recreate passepartout
|
||||
|
||||
45
.github/workflows/lint.yml
vendored
45
.github/workflows/lint.yml
vendored
@@ -22,56 +22,43 @@ jobs:
|
||||
|
||||
- name: Check for forbidden patterns
|
||||
run: |
|
||||
! grep -r "json\." --include="*.lisp" . && \
|
||||
! grep -r "json\." --include="*.lisp" lisp/ && \
|
||||
echo "OK: No JSON in Lisp files"
|
||||
|
||||
- name: Check skills have lisp source blocks
|
||||
- name: Check org files have lisp source blocks
|
||||
run: |
|
||||
FAIL=0
|
||||
for f in skills/*.org; do
|
||||
for f in org/*.org; do
|
||||
if ! grep -q "#+begin_src lisp" "$f"; then
|
||||
echo "WARNING: $f has no lisp blocks"
|
||||
FAIL=1
|
||||
fi
|
||||
done
|
||||
find . -name "*.org" -path "*/skills/*" -exec grep -L "#+begin_src lisp" {} \; | \
|
||||
grep -v "CLA\|CONTRIBUTING\|CHANGELOG\|README\|USER_MANUAL" || true
|
||||
echo "OK: All skills have lisp blocks"
|
||||
echo "OK: Org files checked for lisp blocks"
|
||||
|
||||
- name: Verify each .lisp has a corresponding .org source
|
||||
run: |
|
||||
FAIL=0
|
||||
for f in harness/*.lisp tests/*.lisp; do
|
||||
for f in lisp/*.lisp; do
|
||||
[ -f "$f" ] || continue
|
||||
org="${f%.lisp}.org"
|
||||
[ -f "$org" ] && continue
|
||||
base=$(basename "$f" .lisp)
|
||||
# Check if generated from a parent org via :tangle
|
||||
parent="${base%-tests}.org"
|
||||
parent="${parent%-validator}.org"
|
||||
parent="${parent%-client}.org"
|
||||
if [ -f "harness/$parent" ] || [ -f "skills/$parent" ]; then
|
||||
: # generated from parent org via :tangle
|
||||
elif grep -q ":tangle.*$(basename "$f")" harness/*.org skills/*.org 2>/dev/null; then
|
||||
: # :tangle reference found in another org
|
||||
if [ -f "org/${base}.org" ]; then
|
||||
: # direct match
|
||||
else
|
||||
echo "WARNING: $f has no corresponding .org source"
|
||||
FAIL=1
|
||||
fi
|
||||
done
|
||||
for f in skills/*.lisp; do
|
||||
[ -f "$f" ] || continue
|
||||
org="${f%.lisp}.org"
|
||||
if [ ! -f "$org" ]; then
|
||||
echo "ERROR: $f has no .org source"
|
||||
FAIL=1
|
||||
# Check if generated from a parent org via :tangle header
|
||||
if grep -q ":tangle.*$(basename "$f")" org/*.org 2>/dev/null; then
|
||||
: # :tangle reference found
|
||||
else
|
||||
echo "WARNING: $f has no corresponding .org source"
|
||||
FAIL=1
|
||||
fi
|
||||
fi
|
||||
done
|
||||
[ "$FAIL" = 0 ] && echo "OK: All .lisp files have .org sources"
|
||||
|
||||
- name: Check literate granularity (one function per block)
|
||||
run: |
|
||||
for f in skills/*.org; do
|
||||
for f in org/*.org; do
|
||||
blocks=$(grep -c "^[[:space:]]*(defun " "$f" 2>/dev/null || true)
|
||||
srcblocks=$(grep -c "#+begin_src lisp" "$f" 2>/dev/null || true)
|
||||
if [ "$blocks" -gt "$srcblocks" ] && [ "$srcblocks" -gt 0 ]; then
|
||||
@@ -82,6 +69,6 @@ jobs:
|
||||
|
||||
- name: Check README has quick install
|
||||
run: |
|
||||
grep -q "curl.*opencortex" README.org && \
|
||||
grep -q "curl.*passepartout" README.org && \
|
||||
echo "OK: Quick install in README" || \
|
||||
echo "WARNING: Quick install curl command not found in README"
|
||||
|
||||
17
.github/workflows/release.yml
vendored
17
.github/workflows/release.yml
vendored
@@ -13,19 +13,28 @@ jobs:
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
with:
|
||||
fetch-depth: 0
|
||||
|
||||
- name: Create tarball
|
||||
run: |
|
||||
git archive --format=tar.gz --prefix=opencortex-$(git describe --tags) HEAD -o opencortex.tar.gz
|
||||
git archive --format=tar.gz --prefix=passepartout-$(git describe --tags) HEAD -o passepartout.tar.gz
|
||||
|
||||
- name: Create zipball
|
||||
run: |
|
||||
git archive --format=zip --prefix=opencortex-$(git describe --tags) HEAD -o opencortex.zip
|
||||
git archive --format=zip --prefix=passepartout-$(git describe --tags) HEAD -o passepartout.zip
|
||||
|
||||
- name: Extract tag message as release notes
|
||||
run: |
|
||||
git tag -l --format='%(contents)' ${GITHUB_REF#refs/tags/} > /tmp/release-notes.md
|
||||
echo "--- Notes preview ---"
|
||||
head -20 /tmp/release-notes.md
|
||||
|
||||
- name: Upload to GitHub Release
|
||||
uses: softprops/action-gh-release@v2
|
||||
with:
|
||||
files: |
|
||||
opencortex.tar.gz
|
||||
opencortex.zip
|
||||
passepartout.tar.gz
|
||||
passepartout.zip
|
||||
body_path: /tmp/release-notes.md
|
||||
generate_release_notes: true
|
||||
58
.github/workflows/test.yml
vendored
58
.github/workflows/test.yml
vendored
@@ -27,16 +27,19 @@ jobs:
|
||||
--load /tmp/quicklisp.lisp \
|
||||
--eval '(quicklisp-quickstart:install)'
|
||||
rm -f /tmp/quicklisp.lisp
|
||||
sbcl --noinform --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval '(ql:quickload :fiveam :silent t)' \
|
||||
--eval '(quit)'
|
||||
|
||||
- name: Load and verify harness
|
||||
- name: Load and verify system
|
||||
run: |
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
mkdir -p "$OC_DATA_DIR/harness" "$OC_DATA_DIR/tests"
|
||||
export PASSEPARTOUT_DATA_DIR="$PWD/.github-test"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/test"
|
||||
|
||||
# Tangle harness files into test directory
|
||||
mkdir -p /tmp/oc-build
|
||||
cp harness/*.org "$OC_DATA_DIR/harness/"
|
||||
cd "$OC_DATA_DIR/harness" && for f in *.org; do
|
||||
# Tangle org files into lisp/
|
||||
cp org/*.org "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
cd "$PASSEPARTOUT_DATA_DIR/org" && for f in *.org; do
|
||||
if command -v emacs; then
|
||||
emacs -Q --batch --eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
@@ -46,48 +49,37 @@ jobs:
|
||||
rm -f *.org
|
||||
cd "$OLDPWD"
|
||||
|
||||
# Copy skills, tangle, verify
|
||||
mkdir -p "$OC_DATA_DIR/skills"
|
||||
cp skills/*.org "$OC_DATA_DIR/skills/"
|
||||
cd "$OC_DATA_DIR/skills" && for f in *.org; do
|
||||
if command -v emacs; then
|
||||
emacs -Q --batch --eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$f\")" 2>/dev/null || true
|
||||
fi
|
||||
done
|
||||
rm -f *.org
|
||||
cd "$OLDPWD"
|
||||
# Move test files to test/
|
||||
find "$PASSEPARTOUT_DATA_DIR/lisp" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/test/" \; 2>/dev/null || true
|
||||
|
||||
- name: Load opencortex and initialize skills
|
||||
- name: Load passepartout and initialize skills
|
||||
run: |
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
export PASSEPARTOUT_DATA_DIR="$PWD/.github-test"
|
||||
sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$PWD/\") asdf:*central-registry*)" \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex :silent t)' \
|
||||
--eval "(setf (uiop:getenv \"OC_DATA_DIR\") \"$OC_DATA_DIR\")" \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval "(let ((n (hash-table-count opencortex:*skills-registry*))) (format t \"~%Skills loaded: ~a~%\" n) (unless (>= n 20) (sb-ext:exit :code 1)))"
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :silent t)' \
|
||||
--eval "(setf (uiop:getenv \"PASSEPARTOUT_DATA_DIR\") \"$PASSEPARTOUT_DATA_DIR\")" \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval "(let ((n (hash-table-count passepartout:*skill-registry*))) (format t \"~%Skills loaded: ~a~%\" n) (unless (>= n 10) (sb-ext:exit :code 1)))"
|
||||
|
||||
- name: Daemon smoke test
|
||||
run: |
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
export PASSEPARTOUT_DATA_DIR="$PWD/.github-test"
|
||||
sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$PWD/\") asdf:*central-registry*)" \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval "(ql:quickload '(:opencortex :croatoan))" \
|
||||
--eval "(setf (uiop:getenv \"OC_DATA_DIR\") \"$OC_DATA_DIR\")" \
|
||||
--eval '(opencortex:main)' \
|
||||
> /tmp/oc-daemon.log 2>&1 &
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :silent t)' \
|
||||
--eval "(setf (uiop:getenv \"PASSEPARTOUT_DATA_DIR\") \"$PASSEPARTOUT_DATA_DIR\")" \
|
||||
--eval '(passepartout:main)' \
|
||||
> /tmp/passepartout-daemon.log 2>&1 &
|
||||
DAEMON_PID=$!
|
||||
|
||||
for i in $(seq 1 20); do
|
||||
if ss -tln 2>/dev/null | grep -q 9105; then
|
||||
echo "✓ Daemon ready on port 9105"
|
||||
# Read the initial handshake via a short TCP connection
|
||||
timeout 3 bash -c 'exec 3<>/dev/tcp/localhost/9105; head -c 200 <&3' 2>/dev/null | grep -q "handshake" && \
|
||||
echo "✓ Protocol handshake received"
|
||||
break
|
||||
|
||||
10
.gitignore
vendored
10
.gitignore
vendored
@@ -1,12 +1,16 @@
|
||||
.env
|
||||
opencortex-server
|
||||
passepartout-server
|
||||
\$MEMEX_DIR/
|
||||
*.log
|
||||
*~
|
||||
\#*#
|
||||
opencortex-tui
|
||||
passepartout-tui
|
||||
test_input.txt
|
||||
|
||||
# Generated artifacts (source of truth is .org)
|
||||
/skills/*.lisp
|
||||
/tests/*.lisp
|
||||
/tmp/*.lisp
|
||||
*.fasl
|
||||
docs/#DESIGN_DECISIONS.org# docs/DESIGN_DECISIONS.org~
|
||||
extras/*.elc
|
||||
state/
|
||||
|
||||
1528
CHANGELOG.org
Normal file
1528
CHANGELOG.org
Normal file
File diff suppressed because it is too large
Load Diff
183
README.org
183
README.org
@@ -1,112 +1,163 @@
|
||||
#+TITLE: OpenCortex: Your Autonomous, Plain-Text Life Assistant
|
||||
#+TITLE: Passepartout — The Plain-Text AI Assistant That Never Gets More Expensive
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :opencortex:ai:assistant:
|
||||
#+FILETAGS: :passepartout:ai:assistant:
|
||||
|
||||
#+HTML: <div style="display: flex; gap: 8px; flex-wrap: wrap; margin-bottom: 1em;">
|
||||
#+HTML: <img src="https://img.shields.io/github/v/tag/amrgharbeia/opencortex?label=version&style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/github/license/amrgharbeia/opencortex?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-blue?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-green?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/version-v0.7.2-blue?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/license-AGPLv3-green?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-forestgreen?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-darkgreen?style=flat-square">
|
||||
#+HTML: </div>
|
||||
|
||||
* Quick Install
|
||||
Passepartout is an AI assistant that runs in your terminal. It reads and writes your Org-mode files, executes tasks through a verified safety gate, and works fully offline with local LLMs. Every action the LLM proposes is checked by ten deterministic safety gates before it touches a file, runs a command, or sends a message. The LLM suggests. The gate decides.
|
||||
Everything it knows is a folder of plain text files that you own.
|
||||
|
||||
*Install:*
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/opencortex/main/opencortex.sh | bash -s configure
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout | bash -s configure
|
||||
#+end_src
|
||||
|
||||
Then run ~opencortex tui~ to start chatting.
|
||||
This installs dependencies (SBCL, Quicklisp), tangles the Org source files, and runs the setup wizard for LLM providers. Requires curl and sudo access for package installation.
|
||||
|
||||
* Meet OpenCortex
|
||||
* What is an AI Agent?
|
||||
|
||||
Most AI assistants are just chatbots. You ask a question, they answer, they forget you exist. They trap your conversations in proprietary web apps and silo your data.
|
||||
An AI agent is a program that can act on your behalf — reading files, running commands, sending messages — rather than just answering questions. Unlike a chatbot that only produces text, an agent has /actuators/ that let it affect the world: a shell, a file editor, a message sender. See [[https://en.wikipedia.org/wiki/Software_agent][Software agent]] on Wikipedia.
|
||||
|
||||
*OpenCortex is different. It is an AI that lives inside your own text files.*
|
||||
Passepartout is a /sovereign/ agent: it runs on your machine, operates on your plain-text files, and verifies every action through deterministic safety gates before execution.
|
||||
|
||||
It runs locally on your machine. It reads your notes, organizes your life, executes tasks, and gardens your knowledge base—all while keeping your data in plain text files you own completely.
|
||||
* What Makes Passepartout Different
|
||||
|
||||
* Why OpenCortex Exists
|
||||
** Every action is verified, not trusted.
|
||||
|
||||
The current generation of AI agents have a fundamental flaw: they prioritize quick demos over long-term reliability and user sovereignty.
|
||||
Most AI agents add safety checks as an afterthought — prompt-based guardrails that consume LLM tokens and can be evaded with clever phrasing. Passepartout inverts this: ten deterministic safety gates run in pure Lisp between the LLM's proposal and execution. Secret scanning checks for API key leaks. Path protection blocks reads and writes to sensitive files, including a self-build safety boundary that prevents the agent from modifying its own core pipeline without human review. Shell safety detects destructive commands and injection vectors. Network exfiltration detection flags unauthorized outbound connections. Lisp syntax validation catches malformed code before it writes to disk.
|
||||
|
||||
The biggest problem is data ownership. Most agents bury your memories in opaque databases. If you want to see your own data, you have to ask the AI to fetch it. If the app shuts down, your data is gone.
|
||||
Every gate costs 0 LLM tokens. Every gate is a Common Lisp function, not a prompt. Every gate runs for every action, unconditionally.
|
||||
|
||||
OpenCortex solves this with total plain-text transparency. Your entire life is a folder of text files. OpenCortex manages them the same way you do—with any text editor. No database to migrate, no schema to update, no lock-in.
|
||||
If a gate blocks a proposal, the rejection feedback goes back to the LLM so it can self-correct and try again. If the deterministic Dispatcher is uncertain, it creates a Flight Plan — a human-readable Org buffer you review and approve. The human decides. The Dispatcher learns from your decision and writes a rule for next time.
|
||||
|
||||
* What Makes OpenCortex Different
|
||||
** The more you use it, the cheaper it gets (architectural aspiration)
|
||||
|
||||
Most AI agents are Python applications that happened to call an LLM. OpenCortex is different. It is built in pure Common Lisp—top to bottom, no wrapper, no translation layer.
|
||||
Passepartout is designed with a downward cost curve — an architectural property, not yet measured empirically. Here is the thesis.
|
||||
|
||||
The kernel is Lisp. The skills are Lisp. The memory system is Lisp. The TUI is Lisp. One language from the hardware to the agent's thoughts.
|
||||
When you use Passepartout, the Dispatcher observes every blocked action and every human-approved exception. Each decision becomes a deterministic rule. A file write you approved once becomes an allowed path pattern. A shell command you denied becomes a permanent block. Each hardened rule means one fewer LLM call next time. This rule-learning system is planned for v0.5.0.
|
||||
|
||||
Python agents need a second language for configuration (YAML), a third for memory (JSON or SQLite), and a fourth for deployment (Docker). OpenCortex needs SBCL. That's it.
|
||||
Meanwhile, the foveal-peripheral context model prunes your [[https://en.wikipedia.org/wiki/Memex][memex]] — your personal knowledge base, a term coined by Vannevar Bush in 1945 for a mechanised private library — to the relevant Org subtrees before sending anything to the LLM. The agent does not load your entire knowledge base, or even the entire file like agents that use Markdown do — it loads precisely the headlines that matter. Less context in, fewer tokens out.
|
||||
|
||||
This is not nostalgia for the 1980s. Lisp has two properties that matter for an autonomous agent.
|
||||
These mechanisms are implemented and working today. Token cost measurement and optimization are tracked in the [[file:docs/ROADMAP.org][v0.5.0 Roadmap]]. Until empirically verified, the cost claims in [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] (2-3x fewer tokens for coding, 13-24x for knowledge management) should be read as architectural projections, not measured results.
|
||||
|
||||
First, code is data. In Lisp, the agent can read its own code the same way it reads a text file. It can parse its skills, understand their structure, and modify them at runtime. Python's AST is a foreign object—the agent can inspect it, but not treat it as something it owns.
|
||||
** It edits its own source code. Verified before execution.
|
||||
|
||||
Second, stability. The Common Lisp specification has been stable for decades. Your code does not break because a library changed its API. Dependencies do not rot. A Lisp program from 1995 still runs today.
|
||||
Passepartout can read its own Org-mode source files, propose changes, and hot-reload skills into the running image without restarting. The skill engine loads every skill into a jailed Common Lisp package, validates its syntax, tests its trigger function in isolation, and only then promotes it to the live registry.
|
||||
|
||||
Your data lives in Org-mode files. Not a database. Not JSON. Not a vector store. Just plain text that you can read in any editor, search with grep, and back up any way you want.
|
||||
Core pipeline files — the Perceive-Reason-Act loop, the Merkle-tree memory, the Dispatcher gate stack — are path-protected. The agent could modify its own brain stem, but it cannot do this without human review. Skills and system modules expand freely. The core stays small, protected, and auditable.
|
||||
|
||||
This matters because every other agent makes your data dependent on their app. Their database schema defines what you can store. Their migration scripts decide whether your data survives an upgrade. OpenCortex has no schema. Your memory is a folder of text files. It survives app updates, platform switches, and decades of use.
|
||||
No other AI agent can modify its own reasoning engine and reload the change while it is running. This is not a planned feature. It works today.
|
||||
|
||||
The agent fixes itself. When it encounters an error, it can modify its own code, apply surgical fixes, and learn from the outcome to improve and grow. Skills hot-reload at runtime, so you can extend the system without restarting. And if something goes wrong during a complex operation, it snaps back to a known-good state.
|
||||
** Your memory and your tasks are the same format. Org-mode.
|
||||
|
||||
* Three Problems Every Agent Ignores
|
||||
Passepartout makes a bet that most systems consider too expensive: humans and machines should share the same file format. That format is Org-mode.
|
||||
|
||||
Every other AI assistant has three fundamental flaws that OpenCortex addresses.
|
||||
Your notes, your calendar, your project plans, the agent's memory, and the agent's own source code are all the same thing: Org files in ~/memex/. =headline trees. Property drawers for metadata. Source blocks for code. TODO keywords for task state. Tags for categorization.
|
||||
|
||||
The first is the data silo. Most agents bury your memories in opaque databases. If you want to see your own data, you have to ask the AI to fetch it. If the app shuts down, your data is gone. OpenCortex stores everything in plain text files that you own. No migration needed, no schema to update, no lock-in.
|
||||
When you write a TODO in Emacs, the agent sees it immediately as a native data structure and acts on it. When the agent creates a note, you can open it in any text editor and read it. There is no import/export step, no hidden database (except maybe for indexing), no format conversion. If Passepartout stops existing tomorrow, your data survives in plain text, readable in 2040.
|
||||
|
||||
The second is the hallucination problem. Most agents pipe AI-generated text directly into your terminal. If the model hallucinates, it can delete your files or break your system. OpenCortex splits its brain into two parts. The creative brain (the LLM) suggests actions. The strict guard (deterministic logic) intercepts every proposal before it touches a file or runs a command. If the AI hallucinates, the guard blocks it.
|
||||
** Works offline. Works locally. The safety doesn't stop.
|
||||
|
||||
The third is cloud dependency. Most assistants rely entirely on big tech APIs. When your internet drops, or the service goes down, your assistant dies. Worse, your private notes are constantly sent to third-party servers. OpenCortex runs on your own hardware using free, open-source models. Your private data never leaves your laptop. Cloud models are optional—used only when you explicitly allow them for complex tasks.
|
||||
You can run Passepartout entirely on your hardware with a local LLM via Ollama or some other inference engine. No internet connection required. But unlike most local AI tools, offline mode does not mean safety-last. The ten deterministic safety gates are pure Common Lisp — they run identically whether you are online or off. The Merkle-tree memory with snapshot rollback is in-process, 0 milliseconds, 0 network calls. Semantic retrieval runs on in-image vectors, 0 LLM tokens per query.
|
||||
|
||||
Cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM...) are optional add-ons. When you use them, the model-tier router automatically selects the cheapest provider that matches your task's complexity. Privacy-tagged content stays local even when cloud providers are configured.
|
||||
|
||||
* How It Works
|
||||
|
||||
Every signal — a chat message, a heartbeat tick, a file change notification — moves through three stages:
|
||||
|
||||
#+begin_example
|
||||
Signal → Perceive → Reason → Act
|
||||
normalize LLM proposes dispatch approved action
|
||||
gates verify tool output feeds back
|
||||
#+end_example
|
||||
|
||||
*Perceive* normalizes raw input from any gateway (TUI, CLI, Telegram, Signal) into a uniform signal plist. Buffer updates from Emacs ingest Org AST nodes into memory. Heartbeat ticks trigger background maintenance. HITL commands intercept before the LLM is invoked.
|
||||
|
||||
*Reason* calls the LLM to generate a proposal, then runs the proposal through every registered deterministic gate — sorted by priority, highest first. If a gate rejects (shell command blocked, path protected, secret exposed), the rejection trace feeds back to the LLM for self-correction, up to three retries. If a gate requests human approval, the action becomes a Flight Plan awaiting your decision. If all gates pass, the action proceeds to Act.
|
||||
|
||||
*Act* dispatches the approved action to the correct actuator: shell commands go to the shell actuator (with timeout and output limiting), tool invocations go to the cognitive tool registry, system commands trigger internal harness operations, and chat responses route to the TUI or messaging gateway. Each stage can feed back into Perceive — a tool output becomes the next perception.
|
||||
|
||||
This pipeline is not a single-threaded bottleneck. The priority-queued signal processor (v0.5.0 roadmap) preempts background maintenance for user interactions. The Merkle-tree memory supports concurrent reads and writes through versioned snapshots — multiple signals can process simultaneously without corrupting shared state.
|
||||
|
||||
Deep detail: [[file:docs/ARCHITECTURE.org][Architecture]] for the full code map and pipeline flow, [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] for the rationale behind every architectural choice.
|
||||
|
||||
* Current Capabilities
|
||||
|
||||
Features marked =Stable= ship in the current release. Features marked =Planned= are scheduled in the [[file:docs/ROADMAP.org][Roadmap]].
|
||||
|
||||
| Capability | Status | Since | Notes |
|
||||
|----------------------------------+----------+---------+----------------------------------------------------------------------|
|
||||
| 10-vector deterministic safety | Stable | v0.2.0 | Secrets, paths, self-build, shells, network, lisp, privacy, approval |
|
||||
| Foveal-peripheral context model | Stable | v0.2.0 | Sends relevant subtrees, not all files |
|
||||
| Merkle-tree memory + snapshots | Stable | v0.2.0 | Integrity hashing, copy-on-write rollback |
|
||||
| Self-editing + hot-reload | Stable | v0.2.0 | Agent reads, modifies, reloads its own code |
|
||||
| 8 provider cascade | Stable | v0.1.0 | OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA, local |
|
||||
| Terminal UI (Croatoan) | Stable | v0.2.0 | Scrollback, history, themes, commands, tab completion |
|
||||
| Skill engine (20+ skills) | Stable | v0.1.0 | Jailed loading, topological sort, hot-reload |
|
||||
| Human-in-the-Loop approval | Stable | v0.3.0 | Flight Plan workflow for blocked actions |
|
||||
| Model-tier routing | Stable | v0.3.0 | Sends simple tasks to cheaper models |
|
||||
| Event orchestrator (hooks + cron) | Stable | v0.3.0 | Org-based hook and cron dispatch |
|
||||
| Context manager (project scoping) | Stable | v0.3.0 | Push/pop focus, persist across restart |
|
||||
| Semantic retrieval (trigram) | Stable | v0.4.0 | Trigram Jaccard — lexical overlap, 0 LLM tokens |
|
||||
| TUI gate trace + focus map | Stable | v0.4.0 | Visual safety trace + what the agent is looking at |
|
||||
| Emacs bridge | Stable | v0.4.0 | Native Emacs client over the wire protocol |
|
||||
| Self-build safety boundary | Stable | v0.4.0 | Core files path-protected, HITL Flight Plan required |
|
||||
| Expanded theme (25-color) | Stable | v0.4.0 | 4 named presets (dark/light/gruvbox/solarized), /theme command |
|
||||
| Discord + Slack gateways | Stable | v0.4.0 | 4 platforms: Telegram, Signal, Discord, Slack |
|
||||
| Native embedding inference | Beta | v0.4.x | CFFI llama.cpp binding, nomic-embed-text (768-dim) |
|
||||
| Structured output (function-calling) | Stable | v0.4.2 | LLM tool use via native function-calling API, JSON→plist boundary |
|
||||
| Shell sandbox (bwrap) | Stable | v0.4.3 | Bubblewrap namespace isolation, network/IPC lockdown |
|
||||
| Shell severity classification | Stable | v0.4.3 | catastrophic→dangerous→moderate→harmless tier system |
|
||||
| Token economics + cost tracking | Stable | v0.5.0 | Per-session cost counter, prompt caching, budget enforcement |
|
||||
| Time awareness | Stable | v0.6.0 | Symbolic-time-memory + sensor-time skills, ISO timestamps in prompts |
|
||||
| TUI readline/Ctrl bindings | Stable | v0.7.0 | Ctrl+U/W/A/E/L/D, Ctrl+X+E editor, Ctrl+C interrupt cascade |
|
||||
| TUI Unicode width | Stable | v0.7.0 | char-width: ASCII/CJK/emoji/combining marks, pure Lisp |
|
||||
| TUI scroll notification | Stable | v0.7.0 | :scroll-notify flag, new-message alert when scrolled up |
|
||||
| TUI deeper autocomplete | Stable | v0.7.0 | @ file paths, /theme subcommand, /focus directories |
|
||||
| Streaming responses | Stable | v0.7.2 | SSE streaming, live output in TUI, interrupt-and-redirect |
|
||||
| TUI markdown rendering | Stable | v0.7.2 | Bold/italic/inline code styled via Croatoan attributes |
|
||||
| Priority-queue signal processing | Planned | v0.7.2 | Preempts background for user interactions |
|
||||
| Markdown rendering (full) | Planned | v0.7.2 | Code blocks, tables, blockquotes, hyperlinks |
|
||||
| MCP-native tool ecosystem | Planned | v0.7.0 | 50+ tools from the MCP ecosystem |
|
||||
| Voice gateway | Planned | v0.7.3 | Speech-to-text + text-to-speech via Whisper / ElevenLabs |
|
||||
| Task planning (tree DAG) | Planned | v0.8.0 | Org headline task trees, branch pruning |
|
||||
| Skill creator | Planned | v0.8.0 | LLM drafts skills from natural language, verified before load |
|
||||
| Computer use / vision | Planned | v0.9.0 | Screenshot capture, UI interaction |
|
||||
| SWE-bench evaluation harness | Planned | v0.9.0 | Automated benchmark scoring with Org trajectory audit |
|
||||
| Consensus loop (multi-provider) | Planned | v0.10.0 | Parallel inference, disagreement detection |
|
||||
| GTD integration | Planned | v0.10.0 | Full capture-clarify-organize-reflect-engage |
|
||||
| Deep Emacs integration | Planned | v0.10.0 | Org-agenda, clock time, refile, archive |
|
||||
|
||||
* Quick Start
|
||||
|
||||
You need SBCL (Steel Bank Common Lisp) installed.
|
||||
After installation, the =passepartout= command is available from anywhere.
|
||||
|
||||
#+begin_src bash
|
||||
# Clone the repository
|
||||
git clone https://github.com/amrgharbeia/opencortex.git ~/memex/projects/opencortex
|
||||
|
||||
# Run the Setup Wizard
|
||||
cd ~/memex/projects/opencortex
|
||||
./opencortex.sh setup
|
||||
|
||||
# Verify System Health
|
||||
opencortex doctor
|
||||
|
||||
# Enter the Brain
|
||||
opencortex tui
|
||||
passepartout tui # launch the terminal interface
|
||||
passepartout daemon # start the background daemon (for TUI/CLI/gateways)
|
||||
passepartout doctor # run system health check
|
||||
#+end_src
|
||||
|
||||
* The Onboarding Trifecta
|
||||
|
||||
`opencortex setup` guides you through configuring LLM providers. Tell it how to talk to Ollama, Groq, OpenRouter, or your own endpoint.
|
||||
|
||||
`opencortex gateway link <platform> <token>` connects external chat gateways. Talk to your agent from Telegram while it works on your files.
|
||||
|
||||
`opencortex doctor` shows you what's working, what's broken, and what needs attention.
|
||||
|
||||
* Architecture
|
||||
|
||||
OpenCortex has three layers.
|
||||
|
||||
The Harness is the kernel. It runs the [[file:harness/loop.org][metabolic loop]]—Perceive → Reason → Act—each signal moving through normalization, LLM reasoning, skill verification, and action execution. Depth limits prevent infinite loops. The [[file:harness/memory.org][memory system]] persists to plain-text Org-mode files with snapshot and rollback on errors.
|
||||
|
||||
The Skills are userland—thin harness, fat skills. Modular skills load at runtime. Diagnostics, Configuration, LLM Gateway, Shell Actuation, Emacs Editing, Self-Edit, Self-Fix, Credentials Vault, Tool Permissions, Protocol Validator, and more. Each is an independent Org-mode module. Add new skills without touching the kernel.
|
||||
|
||||
The Interface is what you use to talk to the agent. A native Lisp [[file:harness/tui-client.org][TUI]] with semantic highlighting and history. A [[file:harness/communication.org][TCP socket server]] for CLI interaction. External channels via the gateway—Telegram and beyond.
|
||||
See [[file:docs/USER_MANUAL.org][User Manual]] for the full guide.
|
||||
|
||||
* Project Documentation
|
||||
|
||||
OpenCortex practices what it preaches—the documentation lives in the code.
|
||||
|
||||
The [[file:USER_MANUAL.org][User Manual]] covers setup, configuration, and commands. The [[file:docs/ROADMAP.org][Evolutionary Roadmap]] shows our plan for reaching state-of-the-art capabilities. The [[file:docs/CONTRIBUTING.org][Contributing]] guide teaches you how to add new skills.
|
||||
| Document | Answers |
|
||||
|-------------------------------------------+-------------------------------------------------------|
|
||||
| [[file:docs/USER_MANUAL.org][User Manual]] | How do I use it? |
|
||||
| [[file:docs/ARCHITECTURE.org][Architecture]] | How does it work inside? |
|
||||
| [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] | Why was it built this way? |
|
||||
| [[file:docs/ROADMAP.org][Roadmap]] | Where is it going? When? |
|
||||
| [[file:docs/CONTRIBUTING.org][Contributing]] | How do I contribute? |
|
||||
|
||||
* License
|
||||
|
||||
OpenCortex is released under the [[file:LICENSE][AGPLv3 license]].
|
||||
Passepartout is released under the [[file:LICENSE][AGPLv3 license]].
|
||||
See [[file:CLA.org][CLA.org]] for the Contributor License Agreement.
|
||||
|
||||
796
TODO.org
796
TODO.org
@@ -1,796 +0,0 @@
|
||||
# OpenCortex Project Tasks
|
||||
# All OpenCortex-related TODOs live here. gtd.org links to this file.
|
||||
# Evolutionary context: see docs/ROADMAP.org
|
||||
|
||||
* PHASE: AUTONOMOUS MVP (v0.1.0 Released)
|
||||
:PROPERTIES:
|
||||
:ID: proj-mvp-v0-1-0
|
||||
:END:
|
||||
The "Zero-to-One" release. The agent must be mathematically secure, CLI-first, and capable of autonomous Memex maintenance.
|
||||
|
||||
** DONE 1. Harness Hardening (The Final Audit)
|
||||
*** DONE Audit remaining core skills (`org-skill-policy.org`, `org-skill-bouncer.org`) to the new Literate Granularity standard.
|
||||
*** DONE Implement Verification Lock: Ensure `MANDATORY_SKILLS` pass `validate-lisp-syntax` before boot proceeds.
|
||||
*** DONE Logging & Transparency: Ensure `context-get-system-logs` is utilized by the Reason engine to explain blocked actions.
|
||||
|
||||
** DONE 2. The Autonomous Scribe & Gardener (The Primary Value Prop)
|
||||
*** DONE Implement `org-skill-scribe.org`: Background worker that distills daily chronological logs into structured Zettelkasten notes.
|
||||
*** DONE Implement `org-skill-gardener.org`: Heartbeat-driven skill that autonomously flags orphaned nodes and repairs broken links.
|
||||
|
||||
** DONE 3. The Zero-to-One Experience (setup.org)
|
||||
*** DONE Consolidate installation instructions, `onboard.sh`, and `Dockerfile` into a single, literate `setup.org` file.
|
||||
*** DONE Ensure the setup process interactively builds the `.env` and verifies SBCL/Quicklisp dependencies.
|
||||
|
||||
** DONE 4. CLI-First Actuation
|
||||
CLOSED: [2026-04-14 Tue 09:40]
|
||||
*** DONE Verified the `cli` actuator and inbound gateway handle standard I/O interaction gracefully via a stateful `socat` connection.
|
||||
|
||||
* PHASE: PUBLICATION & VERIFICATION (v0.1.0 Post-Release)
|
||||
:PROPERTIES:
|
||||
:ID: proj-pub-v0-1-0
|
||||
:END:
|
||||
Ensuring the system is ready for the world through collaborative testing, documentation, and licensing.
|
||||
|
||||
** DONE 1. Collaborative End-to-End Testing [2026-04-21 Tue]
|
||||
CLOSED: [2026-04-21 Tue 17:30]
|
||||
*** DONE Verified stable foundation at commit `cab0e5a`.
|
||||
*** DONE Verified boot sequence and bidirectional connectivity.
|
||||
|
||||
** DONE 2. Semantic Reorganization & System Stabilization [2026-04-21 Tue]
|
||||
CLOSED: [2026-04-21 Tue 18:30]
|
||||
*** DONE Rename directories: harness/, library/, environment/, infrastructure/.
|
||||
*** DONE Consolidate Probabilistic engine into reason.lisp.
|
||||
*** DONE Embed bidirectional CLI logic into opencortex.sh.
|
||||
*** DONE Stabilize skill engine: 12/12 skills loaded with package jailing.
|
||||
*** DONE Cleanup legacy documentation and deployment artifacts.
|
||||
|
||||
** DONE 2. Comprehensive Documentation <2026-04-14 Tue>
|
||||
CLOSED: [2026-04-20 Mon 18:00]
|
||||
*** DONE Draft `USER_MANUAL.org`: Focus on CLI interaction, installation, and Memex structure.
|
||||
*** DONE Draft `CONTRIBUTING.org`: Explain Literate Granularity and Skill creation standards.
|
||||
|
||||
** DONE 3. License & Legal Finalization <2026-04-14 Tue>
|
||||
CLOSED: [2026-04-17 Fri 11:25]
|
||||
*** DONE Assign the AGPLv3 open-source license.
|
||||
*** DONE Implement a broad Contributor License Agreement (CLA) process.
|
||||
*** DONE Update `LICENSE` and `CHANGELOG` accordingly.
|
||||
|
||||
** TODO 4. GitHub Migration & Repository Setup <2026-04-14 Tue>
|
||||
*** TODO Migrate primary remote to GitHub and configure canonical repository.
|
||||
*** TODO Set repository topics, badges, issue templates, and CI/CD foundations.
|
||||
|
||||
** TODO 5. Marketing & Social Media Launch <2026-04-14 Tue>
|
||||
*** TODO Execute PR plan (Reddit, Hacker News, X/Twitter).
|
||||
*** TODO Create a short, high-quality terminal demo GIF/video of the TUI interaction.
|
||||
|
||||
* PHASE: INTERACTIVE REFINEMENT (v0.2.0 Target)
|
||||
:PROPERTIES:
|
||||
:ID: proj-refinement-v0-2-0
|
||||
:END:
|
||||
Elevating the user interface from raw shell piping to a high-fidelity, native Lisp experience. Priority: Self-editing is the foundation of all future growth. Full org-mode manipulation makes the agent a true Emacs citizen.
|
||||
|
||||
Roadmap basis: Evolutionary roadmap from README.org. Working backwards from SOTA parity.
|
||||
|
||||
** DONE 0. Autonomous Self-Editing Foundation
|
||||
*** DONE org-skill-lisp-repair (Lisp syntax repair)
|
||||
- Deterministic: auto-balance parens via paren-counting
|
||||
- Probabilistic: LLM generates surgical fix on =:syntax-error= events
|
||||
- Memory rollback on failure
|
||||
DONE: Now in org-skill-lisp-utils (merged from contrib)
|
||||
*** DONE org-skill-emacs-edit (full org-mode manipulation)
|
||||
- Read org buffers, parse AST via org-element
|
||||
- Create/update/delete headlines, set properties, manage TODO states
|
||||
- Handle =id:= links and internal links
|
||||
- Pure Lisp implementation (no Emacs subprocess)
|
||||
*** DONE Expose Structural AST Editing Tools
|
||||
- Wrap org-skill-emacs-edit into def-cognitive-tool definitions
|
||||
- Force LLM to use semantic node updates instead of regex file I/O
|
||||
*** DONE Implement Reflection Loops
|
||||
- Feed rejection traces (syntax errors, policy blocks) back to LLM to trigger self-correction
|
||||
*** DONE Harden Actuators
|
||||
- Fix path-traversal vulnerabilities in file I/O tools (e.g. :write-file)
|
||||
- Enforce Merkle-snapshots on all state-modifying actions
|
||||
*** DONE Implement tool permission tiers (ask/allow/deny)
|
||||
- Per-tool permission plist stored in org-object
|
||||
- =generate-tool-belt-prompt= filters denied tools before LLM sees them
|
||||
- Ask-tier prompts user before execution
|
||||
*** DONE Implement skill hot-reload (=:reload-skill= tool)
|
||||
- Swap compiled skill files without breaking active sockets
|
||||
- Reload skill into jailed package namespace
|
||||
- DONE: Added :reload-skill, :read-file, :write-file, :replace-string tools
|
||||
- DONE: Fixed ASDF compilation bug (position tracking issue with :serial t)
|
||||
- DONE: Added explicit :depends-on declarations to opencortex.asd
|
||||
|
||||
** DONE Engineering Process Improvements [2026-04-23 Wed]
|
||||
*** DONE Fix ASDF compilation bug (position tracking at byte 16834)
|
||||
- Root cause: Duplicate proto-get, bt: prefix issues, :serial t position cache
|
||||
- Fix: Removed duplicate, fixed bt:->bordeaux-threads, explicit dependencies
|
||||
- Added eval-when wrapper for new tools (good Lisp practice)
|
||||
*** DONE Add test-first methodology to engineering standards
|
||||
- Rule 10: Test-first - design tests before coding, run chaos testing
|
||||
- Rule 11: Org as thinking medium - document investigations in prose
|
||||
- Rule 12: Engineering decision audit trail - document root cause, tradeoffs
|
||||
- Added to opencortex-contrib/skills/org-skill-engineering-standards.org
|
||||
*** DONE Perform comprehensive architectural review and evolution strategy [2026-04-27 Mon]
|
||||
- Identified hidden gaps: Org-mode round-trip, sandboxing vulnerabilities, and GC scaling.
|
||||
- Defined "Structural AST Editing" and "Reflection Loops" as core strategic requirements.
|
||||
- Captured findings in [[file:notes/opencortex-architectural-evolution.org][opencortex-architectural-evolution.org]].
|
||||
*** DONE Fix API drift in opencortex-contrib [2026-04-27 Mon]
|
||||
- Standardized legacy keywords (:neuro/:symbolic) to new harness standard (:probabilistic/:deterministic).
|
||||
- Updated 16 skills in opencortex-contrib for kernel compatibility.
|
||||
|
||||
** DONE 4. Core Skills Consolidation [2026-04-23 Thu]
|
||||
- Merged lisp-validator + lisp-repair → org-skill-lisp-utils.org
|
||||
- Added lisp utilities: count-char, deterministic-repair, neural-repair
|
||||
- Added validation: structural, syntactic, semantic checks
|
||||
- Moved org-skill-self-fix from contrib → core
|
||||
- Moved org-skill-engineering-standards from contrib → core
|
||||
- Deleted old org-skill-lisp-validator.org
|
||||
|
||||
** DONE 5. Advanced CLI Onboarding Experience
|
||||
*** DONE Implement interactive Lisp CLI wizard (=opencortex setup=)
|
||||
*** DONE Implement =opencortex gateway link= for Telegram/Signal bot connection [2026-05-02 Sat]
|
||||
*** DONE Implement =opencortex gateway unlink= to disable a gateway [2026-05-02 Sat]
|
||||
*** DONE Implement =opencortex gateway list= to show gateway status [2026-05-02 Sat]
|
||||
*** DONE Implement =opencortex install <skill>= for dynamic skill downloading [2026-05-02 Sat]
|
||||
*** DONE Implement =opencortex doctor= for environment health and API key validation [2026-04-28 Tue]
|
||||
- Verified 22/22 skills loading with clean boot.
|
||||
- Fixed macro conflicts and package jailing bugs.
|
||||
|
||||
** DONE Chaos-Driven Bug Fixes (v0.2.0 Pre-Release) [2026-04-28 Tue]
|
||||
- Fixed major conflict between Type A and Type B def-cognitive-tool macros.
|
||||
- Enforced dynamic-only loading by removing skills from opencortex.asd.
|
||||
- Fixed let/let* sequential binding bugs in emacs-edit and self-edit.
|
||||
- Standardized *cognitive-tools* as a centralized hash table.
|
||||
- Resolved missing in-package declarations in core skills.
|
||||
|
||||
** DONE 1. Common Lisp TUI Implementation [2026-04-28 Tue]
|
||||
*** DONE Integrate =croatoan= for native terminal rendering
|
||||
*** DONE Implement scrollable history viewport for chat and thought streams
|
||||
*** DONE Implement fixed bottom input box with multi-line support and command history
|
||||
*** DONE Implement persistent status bar for background workers (Scribe/Gardener)
|
||||
*** DONE Support syntax highlighting for Lisp code blocks and Org-mode syntax
|
||||
|
||||
** DONE 2. Slash Commands & Interactive Control [2026-04-28 Tue]
|
||||
*** DONE Implement =/help= command for system overview
|
||||
*** DONE Implement =/exit= and =/clear= commands
|
||||
*** DONE Implement =/skill-load <name>= for dynamic hot-reloading
|
||||
*** DONE Implement =/status=, =/config=, =/search=, =/commit= slash commands
|
||||
|
||||
** DONE 3. Direct Lisp-to-Terminal Actuation [2026-04-28 Tue]
|
||||
*** DONE Refactor the =:cli= actuator to use native TUI rendering
|
||||
|
||||
** DONE 4. Persistent REPL for Interactive Development [2026-04-30 Thu]
|
||||
*** DONE Implement org-skill-repl for persistent Lisp evaluation
|
||||
- repl-eval: evaluate code with result+output+error separation
|
||||
- repl-inspect: inspect variables and functions
|
||||
- repl-list-vars: list bound symbols in package
|
||||
- repl-load-file: load files into image
|
||||
- Supports REPL-first workflow with literate reflection in org
|
||||
|
||||
* PHASE: EVENT ORCHESTRATION + HITL (v0.3.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-orchestration-v0-3-0
|
||||
:END:
|
||||
Unified control plane: hooks + cron + routing in one skill. Deep project understanding.
|
||||
|
||||
** TODO 0. Project Renaming (Bouncer → Dispatcher)
|
||||
*** TODO Audit all files for component names to rename
|
||||
*** TODO Rename org-skill-bouncer.org → org-skill-dispatcher.org
|
||||
*** TODO Rename skill-bouncer package → skill-dispatcher
|
||||
*** TODO Rename cognitive tool =:bouncer= → =:dispatcher=
|
||||
*** TODO Update all references in harness, skills, documentation
|
||||
*** TODO Update gtd.org and ROADMAP.org terminology
|
||||
*** TODO Update DESIGN_DECISIONS.org section if applicable
|
||||
*** TODO Verify all tests pass after rename
|
||||
:LOGBOOK:
|
||||
- State "TODO" from "" [2026-05-01 Fri 15:40]
|
||||
:END:
|
||||
|
||||
The Dispatcher's role has evolved beyond security guard. It is the seed of the deterministic engine - it learns to execute procedures without invoking the neural net.
|
||||
|
||||
** TODO 1. Event Orchestrator (unified hooks+cron+routing)
|
||||
*** TODO Integrate contrib org-skill-event-orchestrator
|
||||
- Merge *hook-registry* + *cron-registry* + complexity classifier
|
||||
- Hooks via =#+HOOK:= Org-mode properties
|
||||
- Three complexity tiers: =:REFLEX= (no LLM), =:COGNITION= (light LLM), =:REASONING= (full LLM)
|
||||
- Hook into heartbeat for cron processing
|
||||
|
||||
** TODO 2. Context Manager (project scoping)
|
||||
*** TODO Integrate contrib org-skill-context-manager
|
||||
- Stack-based context with =push-context= / =pop-context=
|
||||
- Path resolution relative to current context
|
||||
- Memory scope: =:scope= property on org-objects (memex/session/project)
|
||||
- Implement lazy-loading proxies for large-scale memory traversal (offload cold nodes to disk)
|
||||
|
||||
** TODO 3. Model-Tier Routing (cost optimization)
|
||||
*** TODO Extend =*model-selector-fn= for complexity-based routing
|
||||
- Heartbeats → smallest model
|
||||
- User input → medium model
|
||||
- Complex reasoning → large model
|
||||
- Source: GBrain sub-agent model routing
|
||||
|
||||
** TODO 4. Memory Scope Segmentation
|
||||
*** TODO Extend org-object with =:scope= property
|
||||
- =:memex= (permanent knowledge)
|
||||
- =:session= (ephemeral context)
|
||||
- =:project= (scoped to current work)
|
||||
- Scope-aware retrieval in memory.lisp
|
||||
|
||||
** TODO 5. Asynchronous Embedding Gateway
|
||||
*** TODO Implement provider-agnostic org-skill-embedding-gateway
|
||||
- Support Ollama, llama.cpp, and OpenAI based on .env config
|
||||
- Implement lazy-loading: edits mark nodes as =:vector :pending=
|
||||
- Background worker thread batches pending nodes and updates Merkle tree silently
|
||||
|
||||
** TODO 6. Slash Commands (TUI ergonomics)
|
||||
*** TODO M-x style command palette
|
||||
*** TODO /- prefix for command mode
|
||||
*** TODO Commands defined in Org-mode
|
||||
|
||||
* PHASE: LONG-HORIZON PLANNING + GIT WORKFLOWS (v0.4.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-planning-v0-4-0
|
||||
:END:
|
||||
Multi-step task mastery, structured tracking with failure handling and course correction.
|
||||
|
||||
** TODO 0. Long-Horizon Planning (task tree DAG)
|
||||
*** TODO Implement org-skill-long-horizon
|
||||
- Decompose complex tasks into Org-mode headline trees
|
||||
- Terminal states: =:todo= → =:next-action= → =:in-progress= → =:done= / =:blocked= / =:stuck=
|
||||
- Parent summarises child results
|
||||
- Branch pruning when paths fail
|
||||
- Source: Claude Code ULTRAPLAN (reimplemented in Lisp)
|
||||
|
||||
** TODO 1. Git Steward (version control integration)
|
||||
*** TODO Integrate contrib org-skill-git-steward
|
||||
- Status, diff, commit, push, branch operations
|
||||
- Policy: commit-before-modify gate (from contrib engineering-standards)
|
||||
- Log commits to memory
|
||||
|
||||
** TODO 2. TDD Runner Integration
|
||||
*** TODO Integrate contrib org-skill-tdd-runner
|
||||
- Run FiveAM tests on file save
|
||||
- Inject =:test-failure= event on red
|
||||
- Hook into self-fix for auto-repair proposals
|
||||
|
||||
** TODO 3. Deep Emacs Integration
|
||||
*** TODO Full org-agenda awareness
|
||||
- Navigate, clock time, refile, archive
|
||||
- Uses org-element + org-id
|
||||
|
||||
* PHASE: INTERACTIVE ACTUATION & ENVIRONMENT STEWARDSHIP (v0.5.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-actuation-v0-5-0
|
||||
:END:
|
||||
Interactive terminal sessions and autonomous dependency management.
|
||||
|
||||
** TODO 0. Interactive PTY Actuator
|
||||
*** TODO Stream long-running process output to the context window (e.g., `npm run dev`, REPLs)
|
||||
*** TODO Implement async interrupt control (Ctrl+C emulation)
|
||||
|
||||
** TODO 1. The Environment Steward
|
||||
*** TODO Autonomously detect missing dependencies (e.g., "Command not found")
|
||||
*** TODO Propose an installation command and retry the failed action
|
||||
|
||||
* PHASE: CREATOR + ARCHITECT + GTD (v0.6.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-creator-v0-5-0
|
||||
:END:
|
||||
Agent bootstraps itself: creates skills autonomously, designs projects from PRDs, tracks work.
|
||||
|
||||
** TODO 0. Skill Creator (autonomous skill generation)
|
||||
*** TODO Integrate contrib org-skill-creator
|
||||
- LLM drafts complete skill org-file from natural language
|
||||
- Mandatory: syntax validation → jail-load → test → register
|
||||
|
||||
** TODO 1. Architect Agent (PRD → PROTOCOL)
|
||||
*** TODO Integrate contrib org-skill-architect
|
||||
- Scan =:STATUS: FROZEN= PRDs
|
||||
- Generate Phase B PROTOCOL from Phase A
|
||||
- Write to same file
|
||||
|
||||
** TODO 2. GTD Integration (project tracking)
|
||||
*** TODO Integrate contrib org-skill-gtd
|
||||
- Full GTD cycle: capture, clarify, organize, reflect, engage
|
||||
- org-gtd v4.0 DAG (=:TRIGGER:=, =:BLOCKER:=)
|
||||
|
||||
** TODO 3. Consensus Loop (multi-model agreement)
|
||||
*** TODO Integrate contrib org-skill-consensus
|
||||
- Run multiple providers for critical decisions
|
||||
- Compare results, detect disagreements
|
||||
- Confidence scoring
|
||||
|
||||
** TODO 4. Web Research (Playwright browsing)
|
||||
*** TODO Integrate contrib org-skill-playwright + org-skill-web-research
|
||||
- Headless Chromium via Python bridge
|
||||
- Text extraction and screenshots
|
||||
- Gemini Web UI automation
|
||||
|
||||
** TODO 5. Memex Management (PARA lifecycle)
|
||||
*** TODO Integrate contrib org-skill-memex + org-skill-workspace-manager
|
||||
- Archive DONE tasks, suggest refiling
|
||||
- Detect orphaned nodes
|
||||
- PARA/Zettelkasten maintenance
|
||||
|
||||
* PHASE: VISUAL GROUNDING & MCP BRIDGE (v0.7.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-vision-v0-7-0
|
||||
:END:
|
||||
Multimodal visual interaction and ecosystem-wide tool compatibility.
|
||||
|
||||
** TODO 0. Computer Use / Vision
|
||||
*** TODO Allow the agent to request host OS or browser screenshots
|
||||
*** TODO Analyze UI and issue precise X/Y coordinate click/type commands via an X11/Wayland bridge
|
||||
|
||||
** TODO 1. MCP Gateway Bridge
|
||||
*** TODO Build a Lisp-native client for the Model Context Protocol
|
||||
*** TODO Connect OpenCortex to external tools and data sources
|
||||
|
||||
* PHASE: THE EVALUATION HARNESS (v0.8.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-eval-v0-8-0
|
||||
:END:
|
||||
Automated benchmarking to mathematically prove the agent's reasoning capabilities.
|
||||
|
||||
** TODO 0. SWE-Bench Harness
|
||||
*** TODO Automated pipeline that clones repositories and feeds GitHub issues
|
||||
*** TODO Track multi-step resolution trajectory, run tests, and score success
|
||||
|
||||
* PHASE: SOTA PARITY (v1.0.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-sota-v1-0-0
|
||||
:END:
|
||||
Feature-complete agent competitive with commercial agents. All borrowed concepts reimplemented in pure Lisp.
|
||||
|
||||
All features from v0.2.0 through v0.8.0 combined, verified, and tested end-to-end.
|
||||
|
||||
| Area | Parity Target |
|
||||
|------|--------------|
|
||||
| Self-improvement | Claude Code self-debug |
|
||||
| Planning | ULTRAPLAN equivalent |
|
||||
| Tool ecosystem | 10+ cognitive tools |
|
||||
| Context window | Semantic search + scope segmentation |
|
||||
| Safety | 6 Policy invariants + formal verification |
|
||||
| Multi-step tasks | Task trees with terminal states |
|
||||
| Code editing | Full file read/write via org manipulation |
|
||||
| Memory | Vector recall in org-object |
|
||||
| Emacs integration | Full org-mode control (exceeds Claude Code) |
|
||||
| Autonomy | 100% local capable (exceeds Claude Code) |
|
||||
|
||||
* PHASE: LISP MACHINE EMERGENCE (v2.0.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-lisp-v2-0-0
|
||||
:END:
|
||||
From Lisp-using agent to true Lisp machine. Agent IS the Emacs process.
|
||||
|
||||
** TODO Lish: Lisp editor as Org-mode IDE
|
||||
- Org-babel for interactive Lisp evaluation
|
||||
- Full REPL in TUI
|
||||
- No bridge needed — direct memory access
|
||||
** TODO Lish: Shell replacement
|
||||
- Lisp-based shell that speaks plists
|
||||
- Org-mode buffers as file system
|
||||
- No bash dependency
|
||||
|
||||
* PHASE: NEUROSYMBOLIC MATURITY (v3.0.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-neuro-v3-0-0
|
||||
:END:
|
||||
Deterministic planner takes the wheel. LLM relegated to semantic translation.
|
||||
|
||||
** TODO Deterministic planner
|
||||
- Planner as pure Lisp function
|
||||
- No LLM needed for scheduling
|
||||
- Generates task graphs without probabilistic inference
|
||||
** TODO Self-correcting gates
|
||||
- Gates learn from false positives (user override patterns)
|
||||
- Adaptive threshold adjustment
|
||||
|
||||
* PHASE: AI STACK INTERNALIZED (v4.0.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-ai-v4-0-0
|
||||
:END:
|
||||
The agent understands its own weights. No external inference.
|
||||
|
||||
** TODO Llama.cpp in Lisp
|
||||
- FFI binding to llama.cpp
|
||||
- No Python subprocess
|
||||
- Pure Common Lisp inference
|
||||
** TODO Weights as sexps
|
||||
- Neural weights represented as Lisp data structures
|
||||
- Homoiconic model introspection
|
||||
|
||||
* PHASE: TRUE AGENCY (v5.0.0)
|
||||
:PROPERTIES:
|
||||
:ID: proj-agency-v5-0-0
|
||||
:END:
|
||||
World models, temporal reasoning, goal persistence across restarts.
|
||||
|
||||
** TODO World models
|
||||
- Agent builds predictive models of user behavior
|
||||
- Project dynamics awareness
|
||||
- System state forecasting
|
||||
** TODO Temporal reasoning
|
||||
- Scheduling and deadline awareness
|
||||
- Elapsed duration tracking
|
||||
- Calendar integration
|
||||
** TODO Goal persistence
|
||||
- Goals survive restarts
|
||||
- Long-term projects tracked in org-objects
|
||||
- Cross-session continuity
|
||||
|
||||
* PHASE: EVOLUTIONARY ROADMAP (Previous — Superseded by Critical Analysis)
|
||||
:PROPERTIES:
|
||||
:ID: proj-old-roadmap
|
||||
:END:
|
||||
Superseded by the critical analysis-informed roadmap above (v0.2.0 through v5.0.0). This section kept for historical reference.
|
||||
|
||||
** TODO v0.1.0: The Autonomous Foundation (Current Release) — Now COMPLETE
|
||||
** TODO v1.0.0 (Phase 2.5): The Verified Wrapper (SOTA Parity) — Now v1.0.0
|
||||
** TODO v2.0.0 (Phase 3): Cannibalizing the Toolchain — Now v2.0.0
|
||||
** TODO v3.0.0 (Phase 4): True Symbolic Determinism — Now v3.0.0
|
||||
|
||||
* PHASE: FOUNDATION (Complete)
|
||||
** DONE Draft Swank/Socket communication protocol between CL and Emacs
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-22 Sun 14:00]
|
||||
:ASSIGNED: Agent
|
||||
:END:
|
||||
** DONE Implement core Perceive-Think-Act loop in Common Lisp
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-22 Sun 14:00]
|
||||
:ASSIGNED: Agent
|
||||
:END:
|
||||
** DONE Implement Persistent Object-Store for Org entities in CL
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-22 Sun 16:30]
|
||||
:ASSIGNED: Agent
|
||||
:END:
|
||||
** DONE Implement LLM Connector (Probabilistic Engine) in CL Daemon
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-22 Sun 17:30]
|
||||
:ASSIGNED: Agent
|
||||
:END:
|
||||
** DONE Design Deterministic Engine Heuristics (Lisp logic over Memory)
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-22 Sun 17:30]
|
||||
:END:
|
||||
** DONE Achieve Phase 3: The Self-Editing Kernel
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-23 Mon 16:30]
|
||||
:END:
|
||||
- Jailing & Sandboxing implemented
|
||||
- Org-Native Skill Standard established
|
||||
- Telemetry & Introspection API active
|
||||
|
||||
* PHASE: THE SOVEREIGN BOUNDARY (Core vs Skills Refactor)
|
||||
:PROPERTIES:
|
||||
:ID: proj-autonomous-boundary
|
||||
:END:
|
||||
Slim down the opencortex microharness by moving non-essential cognitive functions to hot-reloadable user-space skills.
|
||||
|
||||
** DONE Extract LLM Provider Routing to a Skill (neuro.lisp)
|
||||
** DONE Extract Vector Embedding Algorithms to a Skill (embedding.lisp)
|
||||
CLOSED: [2026-04-12 Sun 14:10]
|
||||
:PROPERTIES:
|
||||
:ID: extract-embedding-skill
|
||||
:END:
|
||||
- Created `org-skill-embedding.org`.
|
||||
- Moved logic to `src/embedding-logic.lisp` via tangling.
|
||||
- Updated `system-definition.org`.
|
||||
** DONE Extract Sparse Tree Context Pruning Strategies to a Skill (context.lisp)
|
||||
CLOSED: [2026-04-12 Sun 14:25]
|
||||
:PROPERTIES:
|
||||
:ID: extract-context-skill
|
||||
:END:
|
||||
- Created `org-skill-peripheral-vision.org`.
|
||||
- Moved logic to `src/context-logic.lisp` via tangling.
|
||||
- Updated `system-definition.org`.
|
||||
** DONE Implement `org-skill-peripheral-vision` (Moving embedding logic out of core)
|
||||
CLOSED: [2026-04-12 Sun 14:25]
|
||||
:PROPERTIES:
|
||||
:ID: impl-peripheral-vision
|
||||
:END:
|
||||
** DONE Implement communication protocol Schema Validation (Prevent reader macro injection in communication.lisp)
|
||||
CLOSED: [2026-04-12 Sun 14:45]
|
||||
:PROPERTIES:
|
||||
:ID: communication-protocol-schema-validation
|
||||
:END:
|
||||
- Created `org-skill-protocol-validator.org`.
|
||||
- Integrated `validate-communication-protocol-schema` into `communication.org`.
|
||||
- Added `protocol-validator.lisp` to system definition.
|
||||
** DONE Implement Pluggable communication protocol Integrity Hashing (Core interface, Skill-based algorithms)
|
||||
CLOSED: [2026-04-12 Sun 15:15]
|
||||
:PROPERTIES:
|
||||
:ID: communication-protocol-integrity-hashing
|
||||
:END:
|
||||
- Integrated HMAC-SHA256 (`ironclad:make-mac`) in `literate/communication.org`.
|
||||
** DONE Implement Native Lisp Merkle-Tree Versioning (Short-term undo buffer in memory.lisp)
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Performance: Implement Copy-on-Write (CoW) or Persistent Data Structures for Memory
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Feature: Implement Latent Reflection (Proactive Gardening) using heartbeat idle cycles
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Simplification: Refactor Cognitive Cycle into a Unified Reactive Signal Pipeline
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Resilience: Implement Micro-Rollbacks for the Immune System
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Implement `org-skill-memory-archivist` (Long-term IPFS checkpointing and P2P sync)
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Implement True Lisp Sandboxing (eval-safe mechanism in core and policy in skills)
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Decouple Vendor Logic from Probabilistic Engine (Move Google/Anthropic/OpenAI to Skills)
|
||||
CLOSED: [2026-04-12 Sun 19:15]
|
||||
** DONE Component IV: Comprehensive Core Skill Audit (Review all 39 skills)
|
||||
CLOSED: [2026-04-12 Sun 19:45]
|
||||
:PROPERTIES:
|
||||
:ID: core-skill-audit-task
|
||||
:END:
|
||||
|
||||
** DONE Consolidation I: Unified LLM Gateway (Anthropic, Gemini, Groq, OpenAI, etc.)
|
||||
** DONE Consolidation II: Credentials Vault (Secure Enclave & Masked Logging)
|
||||
** DONE Consolidation III: Homoiconic Memory (Unified Grammar, Bridge, & ID Generation)
|
||||
** DONE Consolidation IV: State Persistence Layer (Unified Local & IPFS Checkpointing)
|
||||
** DONE Consolidation V: Event Orchestrator (Unified Cron, Hooks, & Cognitive Routing)
|
||||
** DONE Consolidation VI: Task Orchestrator (Task Integrity, Delegation, & Consensus)
|
||||
CLOSED: [2026-04-11 Sat 13:45]
|
||||
:PROPERTIES:
|
||||
:ID: task-orchestrator-consolidation
|
||||
:END:
|
||||
- Implemented Parallel Multi-Backend Consensus in neuro.lisp.
|
||||
- Implemented Task Integrity (GTD semantics) in symbolic.lisp.
|
||||
- Integrated Consensus Gate and Delegation hooks in core.lisp.
|
||||
- Verified with new task-orchestrator-tests.lisp.
|
||||
** DONE Implement Unified Envelope Architecture & Channel-Awareness
|
||||
CLOSED: [2026-04-20 Mon 13:20]
|
||||
- Removed specialized :CHAT type; reverted to semantic :REQUEST/:EVENT protocol.
|
||||
- Decoupled routing metadata into a :META envelope (SOURCE, SESSION-ID).
|
||||
- Updated TUI, Emacs, and CLI gateways to use the unified protocol.
|
||||
- Verified end-to-end loop with TUI; kernel correctly routes responses back to origin interface.
|
||||
- Achieved "Equality of Clients" mandate.
|
||||
** DONE Full review of opencortex's harness
|
||||
CLOSED: [2026-05-01 Fri 12:46]
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-04-13 Mon 13:30]
|
||||
:ASSIGNED: Agent
|
||||
:END:
|
||||
- [X] Audit terminology: Replaced OACP with "communication protocol" workspace-wide.
|
||||
- [X] Audit boot sequence: Synchronized loader with `org-skill-policy.org`.
|
||||
- [X] Implement Unified Envelope (Channel-Aware Routing).
|
||||
- [X] Audit core Perceive-Think-Act loop.
|
||||
- [X] Verified protocol framing and reader jailing (`*read-eval* nil`).
|
||||
- [X] Refactored `loop.org` for literate granularity and configuration externalization.
|
||||
- [X] Improved error handling (restricted rollback) and added graceful shutdown.
|
||||
- [X] **FIXED:** Implemented symbolic guard check in `act-gate` via Dispatcher skill refactoring.
|
||||
- [X] **FIXED:** Harness `deterministic-verify` now correctly respects skill triggers.
|
||||
- [X] **FIXED:** Resolved TUI crash by removing `--non-interactive` from `opencortex.sh` and adding defensive coordinate handling.
|
||||
- [X] **VERIFIED:** Confirmed bidirectional TUI communication and signed off v0.2.0.
|
||||
- [X] Ensure alignment with System Policy and Engineering Standards.
|
||||
- [X] Restored structural integrity by fixing `manifest.org` loading sequence.
|
||||
|
||||
** TODO Wake up the Scribe (Implement autonomous weekly Journal-to-Ledger distillation in org-skill-scribe.org)
|
||||
** TODO Implement `org-skill-lisp-repair` (Self-correcting syntax gate for Deterministic Engine)
|
||||
CLOSED: [2026-04-11 Sat 15:10]
|
||||
:PROPERTIES:
|
||||
:ID: lisp-repair-gate
|
||||
:END:
|
||||
- Implemented asynchronous, event-driven repair logic.
|
||||
- Decoupled core from repair logic (emits `:syntax-error` event).
|
||||
- Proven via lisp-repair-tests.lisp (Asynchronous flow verified).
|
||||
** DONE Implement `org-skill-formal-verification` (Prove safety of high-impact actions)
|
||||
CLOSED: [2026-04-11 Sat 18:15]
|
||||
:PROPERTIES:
|
||||
:ID: formal-verification-task
|
||||
:END:
|
||||
- Implemented `org-skill-formal-verification.org`.
|
||||
- Created Lisp-Native Symbolic Prover for security invariants.
|
||||
- Implemented `path-confinement` invariant (restricted to memex root).
|
||||
- Implemented `no-network-exfil` invariant (blocking nc, ssh, etc).
|
||||
- Verified with `formal-verification-tests.lisp`.
|
||||
|
||||
* PHASE: DETERMINISTIC ENGINE REFINEMENT
|
||||
** DONE Verify Autonomous Self-Fix Loop
|
||||
CLOSED: [2026-04-11 Sat 14:20]
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-03-23 Mon 16:30]
|
||||
:END:
|
||||
- Proven repair capability via self-fix-tests.lisp.
|
||||
- Verified surgical code patching and hot-reloading.
|
||||
- Documentation and RCA complete.
|
||||
** DONE Implement "Planning Mode" (Deterministic Engine Dispatcher) for Complex Actions
|
||||
CLOSED: [2026-04-11 Sat 15:30]
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-04-01 Wed 17:00]
|
||||
:END:
|
||||
- Implemented `dispatcher-check` interceptor in `symbolic.lisp`.
|
||||
- Created `org-skill-dispatcher.org` for flight plan serialization.
|
||||
- Verified asynchronous Org-native approval loop via `dispatcher-tests.lisp`.
|
||||
** DONE Implement Authorization Gate (communication protocol) for "Planning Mode"
|
||||
CLOSED: [2026-04-11 Sat 15:30]
|
||||
:PROPERTIES:
|
||||
:CREATED: [2026-04-01 Wed 17:00]
|
||||
:END:
|
||||
- Integrated with Org-mode state transitions (`PLAN` -> `APPROVED`).
|
||||
- Leveraged Memory event bus for asynchronous re-injection.
|
||||
|
||||
** DONE Refactor Architecture Terminology (Associative -> Probabilistic, Deliberate -> Deterministic)
|
||||
CLOSED: [2026-04-12 Sun 21:00]
|
||||
:PROPERTIES:
|
||||
:ID: terminology-refactor-task
|
||||
:END:
|
||||
- Updated codebase-wide terminology to use Probabilistic/Deterministic Engines.
|
||||
- Replaced System 1/2 with Probabilistic/Deterministic Engines respectively.
|
||||
|
||||
** DONE Refactor org-skill-policy.org: Concrete Invariants, Conflict Hierarchy, and Auditable Gate
|
||||
CLOSED: [2026-04-22 Wed 11:50]
|
||||
:PROPERTIES:
|
||||
:ID: policy-refactor-concrete-invariants
|
||||
:END:
|
||||
- Added explicit Override Hierarchy (Transparency > Autonomy > Bloat > Mentorship > Sustainability).
|
||||
- Implemented `policy-check-transparency`: blocks user-facing actions without :explanation.
|
||||
- Implemented `policy-check-autonomy`: flags proprietary domain references as autonomy debt.
|
||||
- Implemented `policy-check-bloat`: warns on :create-skill actions exceeding size threshold.
|
||||
- Implemented `policy-check-mentorship`: blocks high-impact actions missing :mentorship-note.
|
||||
- Implemented `policy-check-sustainability`: logs cloud-provider usage as sustainability debt.
|
||||
- Implemented `policy-explain`: formats auditable rationale for every policy decision.
|
||||
- Implemented `policy-find-engineering-standards-gate`: robust cross-package search for standards skill.
|
||||
- Hardened `policy-deterministic-gate`: never returns NIL silently; always returns action or auditable log.
|
||||
- Raised skill priority from 100 to 500 to ensure it runs before other deterministic gates.
|
||||
|
||||
** DONE Add Invariant 6 (Modularity) and Harness Boundary Contract to Policy/Manifest
|
||||
CLOSED: [2026-04-22 Wed 12:10]
|
||||
:PROPERTIES:
|
||||
:ID: policy-modularity-invariant
|
||||
:END:
|
||||
- Added Modularity as Invariant 6 in `org-skill-policy.org`: general life principle that complexity must live at the edges.
|
||||
- Implemented `policy-check-modularity`: blocks modifications to protected core paths unless `:modularity-justification` is provided.
|
||||
- Defined `*modularity-protected-paths*` as project-configurable variable (defaults: harness/, opencortex.asd).
|
||||
- Updated Override Hierarchy to include Modularity between Bloat and Mentorship.
|
||||
- Added Harness Boundary Contract section to `harness/manifest.org` documenting primary boundary files and generated artifacts.
|
||||
- Converted checkbox sub-tasks to hierarchical TODO headlines per GTD standard.
|
||||
|
||||
** DONE Implement `org-skill-lisp-validator` (3-phase deterministic validation gate)
|
||||
CLOSED: [2026-04-22 Wed 12:30]
|
||||
:PROPERTIES:
|
||||
:ID: lisp-validator-implementation
|
||||
:END:
|
||||
- Created 3-phase validation pipeline: Structural (O(n) paren scanner), Syntactic (reader with *read-eval* nil), Semantic (whitelist AST walk).
|
||||
- Implemented `lisp-validator-validate` returning structured plists for machine parsing.
|
||||
- Exposed `:validate-lisp` cognitive tool for Probabilistic Engine self-correction.
|
||||
- Replaced `validate-lisp-syntax` in `harness/skills.org` with delegation to the validator.
|
||||
- Added mandatory validation rule to Probabilistic Engine system prompt in `harness/reason.org`.
|
||||
- Fixed paren balance and `return-from` compilation errors in org source; tangled and validated in SBCL.
|
||||
|
||||
** DONE Fix Skill Loader to Respect `:tangle` Blocks and Eliminate Circular Dependency
|
||||
CLOSED: [2026-04-22 Wed 12:45]
|
||||
:PROPERTIES:
|
||||
:ID: skill-loader-tangle-fix
|
||||
:END:
|
||||
- Updated `load-skill-from-org` in `harness/skills.org` to only collect blocks with `:tangle` directives pointing to runtime `.lisp` files, excluding `tests/` and `test/` paths.
|
||||
- Added fallback to `validate-lisp-syntax` so it uses a basic reader check when `lisp-validator-validate` is not yet loaded (breaks circular harness->skill dependency).
|
||||
- Verified full boot: 13/13 skills loaded successfully into SBCL, including `skill-lisp-validator` at priority 900 and `skill-policy` at priority 500.
|
||||
|
||||
* TRACK: SECURITY & CONTAINMENT (The 5-Vector Dispatcher Matrix)
|
||||
** DONE Implement Path-Based Scoping for File Writes (DNA/State vs Work)
|
||||
CLOSED: [2026-04-12 Sun 15:15]
|
||||
:PROPERTIES:
|
||||
:ID: path-based-scoping
|
||||
:END:
|
||||
- Implemented as `path-confinement` invariant in `org-skill-formal-verification.org`.
|
||||
** DONE Implement Network Exfiltration Gate (Intercept generic HTTP requests)
|
||||
CLOSED: [2026-04-12 Sun 15:15]
|
||||
:PROPERTIES:
|
||||
:ID: network-exfiltration-gate
|
||||
:END:
|
||||
- Implemented as `no-network-exfil` invariant in `org-skill-formal-verification.org`.
|
||||
** TODO Implement Secret Exposure Gate (Intercept reads to .env, keys)
|
||||
|
||||
* TRACK: INTELLIGENCE & ACTUATION (The Engines)
|
||||
** DONE Verify individual provider track (Anthropic, Gemini, Groq, OpenAI, OpenRouter, Ollama)
|
||||
CLOSED: [2026-04-11 Sat 15:45]
|
||||
:PROPERTIES:
|
||||
:ID: provider-verification-track
|
||||
:END:
|
||||
- Added unit tests for each provider in `llm-gateway-tests.lisp`.
|
||||
- Mocked `dex:post` to verify JSON payload formatting and response parsing.
|
||||
- Implemented robust `get-nested` helper to handle various provider structures.
|
||||
- Integrated `llm-gateway` and `credentials-vault` into `opencortex.asd`.
|
||||
** TODO Verify org-skill-shell-actuator formal safety harnesses
|
||||
** DONE Build Playwright-Python Bridge for high-fidelity browsing
|
||||
CLOSED: [2026-04-11 Sat 18:30]
|
||||
:PROPERTIES:
|
||||
:ID: playwright-bridge-task
|
||||
:END:
|
||||
- Created `scripts/browser-bridge.py` (Playwright wrapper).
|
||||
- Implemented `org-skill-playwright.org`.
|
||||
- Registered `:browser` cognitive tool (JS-rendering, text extraction, screenshots).
|
||||
- Updated `Dockerfile` with Python/Playwright dependencies.
|
||||
- Verified with `playwright-tests.lisp`.
|
||||
|
||||
|
||||
* TRACK: COMMUNICATION & INTERFACES
|
||||
** DONE Implement org-skill-gateway-telegram
|
||||
CLOSED: [2026-04-11 Sat 16:15]
|
||||
:PROPERTIES:
|
||||
:ID: gateway-telegram-task
|
||||
:END:
|
||||
- Implemented `org-skill-gateway-telegram.org`.
|
||||
- Added automated background polling for Telegram GetUpdates.
|
||||
- Implemented `:telegram` actuator for outbound responses.
|
||||
- Refactored `org-skill-chat` to be channel-aware.
|
||||
- Verified with `gateway-telegram-tests.lisp`.
|
||||
** DONE Implement org-skill-gateway-signal
|
||||
CLOSED: [2026-04-11 Sat 16:50]
|
||||
:PROPERTIES:
|
||||
:ID: gateway-signal-task
|
||||
:END:
|
||||
- Implemented `org-skill-gateway-signal.org` (signal-cli wrapper).
|
||||
- Added background polling for `signal-cli receive --json`.
|
||||
- Implemented `:signal` actuator for outbound responses.
|
||||
- Updated `org-skill-chat` to support Signal channel.
|
||||
- Verified with `gateway-signal-tests.lisp`.
|
||||
** DONE Implement org-skill-gateway-matrix
|
||||
CLOSED: [2026-04-11 Sat 17:15]
|
||||
:PROPERTIES:
|
||||
:ID: gateway-matrix-task
|
||||
:END:
|
||||
- Implemented `org-skill-gateway-matrix.org` (Client-Server API).
|
||||
- Added background polling for `/sync` with token persistence.
|
||||
- Implemented `:matrix` actuator for `m.room.message` delivery.
|
||||
- Updated `org-skill-chat` to support Matrix channel and room IDs.
|
||||
- Verified with `gateway-matrix-tests.lisp`.
|
||||
|
||||
* TRACK: DEPLOYMENT & INFRASTRUCTURE
|
||||
** DONE Create Dockerfile and docker-compose.yml for containerized setup
|
||||
CLOSED: [2026-04-11 Sat 17:30]
|
||||
:PROPERTIES:
|
||||
:ID: docker-infra-task
|
||||
:END:
|
||||
- Created `Dockerfile` (Debian-based, SBCL + Quicklisp + signal-cli).
|
||||
- Created `docker-compose.yml` with host-volume mapping for memex.
|
||||
- Created `docs/deployment.org` guide.
|
||||
** TODO Create Bare Metal installation scripts/playbooks
|
||||
** TODO Create LXC (Linux Containers) template/guide
|
||||
** TODO Create VM Vagrantfiles/Cloud-init configs
|
||||
|
||||
* TRACK: MAINTENANCE & HYGIENE
|
||||
** TODO [RECURRING: Monthly] Review and test Infrastructure Dependency Upgrades
|
||||
:PROPERTIES:
|
||||
:ID: monthly-infra-audit
|
||||
:REPEAT_TO_STATE: TODO
|
||||
:END:
|
||||
*** TODO Check for new Debian security patches (`apt-get update` check)
|
||||
*** TODO Check for new `signal-cli` releases (compare vs v0.14.0)
|
||||
*** TODO Check for new Quicklisp distribution (monthly snapshot)
|
||||
*** TODO Verification: Update `Dockerfile`, run `docker-compose build --no-cache`, and execute full test suite
|
||||
*** TODO If all tests pass, commit updated `Dockerfile` and `.asd` dependencies
|
||||
|
||||
* TRACK: COMMUNITY & DOCS
|
||||
** TODO Write Quickstart Guide
|
||||
** TODO Write Skill Creation Guide
|
||||
** TODO Write Architecture Deep-Dive
|
||||
** TODO Clean up GitHub repository structure and add CI/CD
|
||||
** TODO Create Marketing Material (Landing page copy, diagrams)
|
||||
** TODO Draft Release Plan checklist
|
||||
|
||||
* SUB-PROJECT: THE BOOT SEQUENCE (skills.lisp)
|
||||
:PROPERTIES:
|
||||
:ID: proj-skill-boot-sequence
|
||||
:END:
|
||||
** DONE Refactor `skills.lisp` into a Micro-Loader (Harness)
|
||||
CLOSED: [2026-04-12 Sun 19:10]
|
||||
** DONE Implement Topological Sort based on `#+DEPENDS_ON:` tags
|
||||
CLOSED: [2026-04-12 Sun 15:15]
|
||||
:PROPERTIES:
|
||||
:ID: topological-sort-skills
|
||||
:END:
|
||||
- Implemented in `literate/skills.org`.
|
||||
** DONE Enforce `org-skill-system-invariants` as the mandatory Gateway Skill (Loaded first)
|
||||
CLOSED: [2026-04-12 Sun 15:15>
|
||||
:PROPERTIES:
|
||||
:ID: enforce-mandatory-skill
|
||||
:END:
|
||||
- Enforced in `initialize-all-skills` in `literate/skills.org`.
|
||||
** DONE Formalize the "Minimal Boot Set" (Router, Vision, Steward, Actuator)
|
||||
CLOSED: [2026-04-12 Sun 19:10>
|
||||
@@ -1,61 +0,0 @@
|
||||
#+TITLE: OpenCortex User Manual
|
||||
#+AUTHOR: Agent
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:manual:
|
||||
|
||||
* Introduction
|
||||
Welcome to the OpenCortex User Manual. This guide provides the operational knowledge required to manage your sovereign Lisp Machine and its neural skills.
|
||||
|
||||
* System Architecture
|
||||
OpenCortex follows a "Purified Kernel" model. The core harness handles essential I/O, while all high-level logic resides in sovereign skills.
|
||||
|
||||
** XDG Directory Standard
|
||||
To ensure POSIX compliance, OpenCortex stores its files in standard Linux locations:
|
||||
|
||||
| Type | Path | Purpose |
|
||||
| :--- | :--- | :--- |
|
||||
| **Config** | `~/.config/opencortex/` | User settings, `.env` secrets, and provider registry. |
|
||||
| **Data** | `~/.local/share/opencortex/` | Tangled Lisp artifacts and the compiled engine. |
|
||||
| **State** | `~/.local/state/opencortex/` | Brain snapshots, logs, and Merkle-memory. |
|
||||
| **Bin** | `~/.local/bin/opencortex` | The global CLI shim. |
|
||||
|
||||
* Command Reference
|
||||
|
||||
** `opencortex setup`
|
||||
The interactive configuration wizard. Use this to:
|
||||
- Define your identity and the Agent's name.
|
||||
- Register LLM providers (Ollama, Groq, Anthropic, etc.).
|
||||
- The wizard automatically splits sensitive tokens into `~/.config/opencortex/.env`.
|
||||
|
||||
** `opencortex gateway link <platform> <token>`
|
||||
Connects OpenCortex to external communication gateways.
|
||||
- **Example:** `opencortex gateway link telegram <my_bot_token>`
|
||||
- **Example:** `opencortex gateway unlink telegram` to disable
|
||||
- **Example:** `opencortex gateway list` to see status
|
||||
|
||||
** `opencortex doctor`
|
||||
Your primary diagnostic tool. Run this if the system feels sluggish or fails to boot. It verifies:
|
||||
- External dependencies (sbcl, git, socat).
|
||||
- XDG directory existence and permissions.
|
||||
- LLM connectivity.
|
||||
|
||||
** `opencortex tui`
|
||||
Launches the native Lisp Terminal User Interface.
|
||||
- **Highlighting:** Semantic color-coding for Lisp and Org syntax.
|
||||
- **Scrolling:** Use `PgUp`/`PgDn` to navigate history.
|
||||
- **Exit:** Type `/exit` or `Ctrl+C` to close.
|
||||
|
||||
* Configuration Strategy
|
||||
OpenCortex uses a **Hybrid Storage** model for maximum security and flexibility.
|
||||
|
||||
** 1. Secrets (`.env`)
|
||||
Found in `~/.config/opencortex/.env`. This file stores raw API tokens. It is never automatically read by the Lisp structural parser to prevent accidental leakage into logs.
|
||||
|
||||
** 2. Metadata (`providers.lisp`)
|
||||
Found in `~/.config/opencortex/providers.lisp`. This stores non-sensitive configuration like model names, base URLs, and user preferences as native Lisp S-expressions.
|
||||
|
||||
* Troubleshooting
|
||||
If `opencortex doctor` reports a `FAIL`:
|
||||
1. Check that your `PATH` includes `/usr/bin` and `/usr/local/bin`.
|
||||
2. Ensure `sbcl` is installed.
|
||||
3. If LLM connectivity fails, verify your API key in `~/.config/opencortex/.env`.
|
||||
1
docs/.#DESIGN_DECISIONS.org
Symbolic link
1
docs/.#DESIGN_DECISIONS.org
Symbolic link
@@ -0,0 +1 @@
|
||||
user@amr.1407003:1778162380
|
||||
1
docs/.#ROADMAP.org
Symbolic link
1
docs/.#ROADMAP.org
Symbolic link
@@ -0,0 +1 @@
|
||||
user@amr.1407003:1778162380
|
||||
139
docs/ARCHITECTURE.org
Normal file
139
docs/ARCHITECTURE.org
Normal file
@@ -0,0 +1,139 @@
|
||||
#+TITLE: Passepartout Architecture
|
||||
#+AUTHOR: Agent
|
||||
#+STARTUP: content
|
||||
|
||||
* The Four Quadrants
|
||||
|
||||
Passepartout divides cognition along two axes: **Foreground vs Background** (initiated by the user vs running autonomously) and **Probabilistic vs Deterministic** (LLM-driven vs pure Lisp logic).
|
||||
|
||||
| | Probabilistic (LLM) | Deterministic (Lisp) |
|
||||
|----------------+-------------------------------------------------------------+------------------------------------------------------------|
|
||||
| **Foreground** | Chat responses, task execution, code generation | Shell execution, file I/O, safety gates, dispatcher checks |
|
||||
| **Background** | Scribe distillation, vector embedding, autonomous decisions | Heartbeat, cron jobs, memory auto-save, gateway polling |
|
||||
|
||||
The Probabilistic engine proposes. The Deterministic engine verifies and executes. No proposal from the LLM touches a file, runs a command, or sends a message without passing through at least one deterministic gate.
|
||||
|
||||
* Architectural Layers
|
||||
|
||||
** Core Pipeline (loaded by ASDF — the harness)
|
||||
- package definition: defpackage, cognitive tools, logging
|
||||
- memory: memory-object struct, Merkle hashing, snapshots, persistence
|
||||
- context: foveal-peripheral rendering, context assembly for LLM
|
||||
- pipeline: perceive → reason → act stages, orchestrator, heartbeat
|
||||
- skills engine: defskill macro, topological sorter, jailed loading
|
||||
- communication: framed TCP protocol, actuator registry, daemon server
|
||||
- diagnostics: health checks, doctor CLI
|
||||
|
||||
** Skills (loaded at runtime by the skill engine)
|
||||
- gateway: TUI, CLI, messaging (Telegram, Signal)
|
||||
- system-model: provider dispatch, router, embeddings, model explorer
|
||||
- security: dispatcher (safety gate), policy, permissions, validator, vault
|
||||
- programming: Lisp, Org, literate tools, REPL, standards
|
||||
- system: config, archivist, self-improve, memory introspection, shell actuator, event-orchestrator, context-manager, setup
|
||||
|
||||
** Clients (connect to daemon via framed TCP protocol)
|
||||
- TUI: Croatoan-based terminal interface (model-view architecture, dirty-flag rendering)
|
||||
- CLI: pipe-friendly command-line gateway
|
||||
- Emacs: elisp bridge speaking the wire protocol (planned v0.4.0)
|
||||
|
||||
* Pipeline Flow
|
||||
|
||||
Every signal moves through three stages:
|
||||
|
||||
```
|
||||
Signal → Perceive (normalize) → Reason (think + verify) → Act (dispatch)
|
||||
```
|
||||
|
||||
The signal is a plist: ~(:TYPE :EVENT :META (...) :PAYLOAD (:SENSOR :user-input :TEXT "..."))~
|
||||
|
||||
1. **Perceive** normalizes raw input from any gateway into a uniform signal
|
||||
2. **Reason** calls the LLM to generate a proposal, then runs the proposal through all registered deterministic gates (sorted by priority). If a gate rejects the proposal, the rejection trace feeds back to the LLM for self-correction (up to 3 retries)
|
||||
3. **Act** dispatches the approved action to the registered actuator (~:cli~, ~:tool~, ~:system~, ~:shell~, ~:telegram~, ~:signal~)
|
||||
|
||||
Each stage can produce feedback signals that loop back to Perceive (e.g., a tool-execute action produces a ~:tool-output~ event that becomes the next perception).
|
||||
|
||||
** Depth limiting
|
||||
|
||||
A depth counter prevents infinite loops. If a signal's depth exceeds 10, it is silently dropped. This is the circuit breaker for runaway recursive cycles.
|
||||
|
||||
* Foveal-Peripheral Context Model
|
||||
|
||||
When the agent assembles context for the LLM, it does not send the entire memory. It renders a sparse outline using three rules:
|
||||
|
||||
1. *Depth ≤ 2* — the root node and its immediate children are always included (title and properties only, no content).
|
||||
2. *Foveal focus* — the node the user is currently interacting with is rendered in full, including its body content and all descendants.
|
||||
3. *Semantic relevance* — any node whose embedding vector has cosine similarity ≥ threshold (default 0.75) to the foveal node is rendered in full.
|
||||
4. *Temporal relevance* — nodes modified within a time window (current session, today) are rendered in full. Deadlines and scheduled items approaching within the warning window (default 60 minutes) are surfaced proactively in the awareness context. Nodes older than the window are title-only. This is the temporal dimension of the foveal-peripheral model: prune in time as well as in semantic space.
|
||||
|
||||
Nodes that don't match any rule are rendered as title-only — a single Org headline with its :ID: property. This keeps active context between 2,000–4,000 tokens for typical memex sizes, versus 50,000–150,000 tokens for a full serialization. The embedding vectors that power semantic retrieval are computed at ingest time (~ingest-ast~ in core-memory.lisp) and can use local models (Ollama), cloud APIs (OpenAI embeddings), or a zero-dependency lexical fallback (trigram Jaccard similarity).
|
||||
|
||||
For the rationale behind sparse-tree rendering and why this architecture outperforms "load everything" systems, see Design Decisions: Org-Mode as Unified AST.
|
||||
|
||||
* Dispatcher Gate Stack
|
||||
|
||||
Every action the LLM proposes passes through a stack of deterministic gates before execution. Gates are registered as skills with ~defskill~ and sorted by priority (highest first) in ~cognitive-verify~ (core-loop-reason.lisp).
|
||||
|
||||
| Priority | Gate | What It Checks |
|
||||
|----------+---------------------------+----------------------------------------------------------|
|
||||
| 600 | security-permissions | Tool permission table (allow/ask/deny per tool) |
|
||||
| 600 | security-vault | Credential storage integrity |
|
||||
| 500 | security-policy | Requires :explanation on every action |
|
||||
| 150 | security-dispatcher | 11-check safety: lisp, secret path, self-build, |
|
||||
| | (the Dispatcher) | content exposure, vault, privacy tags, privacy text, |
|
||||
| | | shell safety, network exfil, high-impact approval |
|
||||
| 95 | security-validator | Protocol schema validation |
|
||||
| 100 | system-archivist | Scribe and Gardener maintenance on heartbeat |
|
||||
| 80 | system-event-orchestrator | Cron job dispatch on heartbeat |
|
||||
|
||||
Gates return either the action (passed through unchanged), a rejection (:LOG or :EVENT with block reason), or an approval request (:EVENT with :level :approval-required). Rejections feed back to the LLM as a rejection trace — the model sees what it proposed, which gate blocked it, and why, and retries with that context (up to 3 retries). Approval requests create Flight Plan Org nodes requiring human review via the HITL workflow.
|
||||
|
||||
Every gate is a pure Common Lisp function. Verification costs 0 LLM tokens. Contrast with prompt-based guardrails (Claude Code, OpenClaw, Hermes Agent) which consume 100–500 LLM tokens per verification.
|
||||
|
||||
For the rationale behind deterministic vs prompt-based safety, see Design Decisions: The Probabilistic-Deterministic Split and The Dispatcher as Learning System.
|
||||
|
||||
* Embedding & Semantic Retrieval Pipeline
|
||||
|
||||
Every memory-object can carry an embedding vector for semantic search. The pipeline:
|
||||
|
||||
1. *Ingest* — ~ingest-ast~ (core-memory.lisp) calls ~embeddings-compute~ on new objects, storing the vector in ~memory-object-vector~.
|
||||
2. *Queue* — objects with stale vectors are queued via ~mark-vector-stale~. The ~embed-all-pending~ cron job (every 10 minutes, :REFLEX tier) drains the queue and recomputes vectors.
|
||||
3. *Retrieval* — ~context-awareness-assemble~ (core-context.lisp) passes the foveal node's vector to ~context-object-render~. Nodes with cosine similarity ≥ threshold against the foveal vector are rendered in full rather than as title-only.
|
||||
|
||||
Three backends are available, selected via ~EMBEDDING_PROVIDER~:
|
||||
- :local — Ollama-compatible /api/embeddings endpoint (e.g., nomic-embed-text)
|
||||
- :openai — OpenAI /v1/embeddings API (e.g., text-embedding-3-small)
|
||||
- :hashing — zero-dependency lexical fallback using trigram Jaccard similarity (replaced SHA-256 hashing in v0.4.0 because cryptographic hashes maximise output divergence — the opposite of what a similarity metric needs)
|
||||
|
||||
For the design rationale, see Design Decisions: Token Economics and Performance Advantage.
|
||||
|
||||
* Skill Lifecycle
|
||||
|
||||
1. *Discovery:* ~skill-initialize-all~ scans the skills directory, globs for ~*.lisp~ files (excluding ~core-*~ files which are loaded by ASDF)
|
||||
2. *Sorting:* ~skill-topological-sort~ orders skills by their ~#+DEPENDS_ON:~ declarations
|
||||
3. *Loading:* Each skill is loaded into a jailed package (~passepartout.skills.<skill-name>~). The loader removes ~in-package~ forms, evaluates the remaining code in the jailed package, and exports symbols matching the skill's short name to ~passepartout~
|
||||
4. *Registration* The skill's ~defskill~ call creates a ~skill~ struct in ~*skill-registry*~, registering its trigger function, probabilistic prompt generator, deterministic gate, and system-prompt augment
|
||||
5. *Triggering:* On each cognitive cycle, ~skill-triggered-find~ iterates the registry and returns the highest-priority skill whose trigger matches the context
|
||||
6. *Hot-reload:* A skill can be replaced at runtime by loading a new version into its jailed package — no restart needed
|
||||
|
||||
* Communication protocol Format
|
||||
|
||||
All communication between the daemon and its gateways (TUI, CLI, Emacs) uses length-prefixed plists over TCP:
|
||||
|
||||
```
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.4.0"))
|
||||
```
|
||||
|
||||
The 6-character hex prefix encodes the payload length. The payload is a ~prin1~-serialized plist. ~*read-eval*~ is bound to nil on the receiving end to prevent code injection.
|
||||
|
||||
** Standard message envelope:
|
||||
|
||||
| Key | Value | Meaning |
|
||||
|-----|-------|---------|
|
||||
| ~:TYPE~ | ~:REQUEST~, ~:EVENT~, ~:RESPONSE~, ~:LOG~, ~:STATUS~ | Message category |
|
||||
| ~:META~ | plist | ~:SOURCE~, ~:SESSION-ID~, ~:reply-stream~ |
|
||||
| ~:PAYLOAD~ | plist | Action-specific data (~:SENSOR~, ~:ACTION~, ~:TEXT~) |
|
||||
| ~:DEPTH~ | integer | Recursion counter for loop prevention |
|
||||
|
||||
The protocol lifecycle begins with a handshake: the daemon sends a :handshake action with its version, and the client responds with its capabilities. After handshake, either side can send any message type. The daemon never initiates a disconnect — clients poll for messages and reconnect on EOF.
|
||||
|
||||
Planned for v0.6.3: streaming chunk frames (~:type :stream-chunk~) carrying partial LLM output. The final chunk is an empty string signalling end-of-stream, enabling interrupt-and-redirect from the client side.
|
||||
@@ -1,36 +0,0 @@
|
||||
#+TITLE: Changelog
|
||||
#+STARTUP: content
|
||||
|
||||
* v0.2.0 - Interactive Refinement (2026-04-29)
|
||||
This release focuses on professionalizing the environment and enhancing the agent's structural capabilities.
|
||||
|
||||
** Features
|
||||
- **Enhanced Lisp/Org Utilities:** Structural editing, REPL evaluation, and automated formatting to ensure code integrity.
|
||||
- **Namespace Standardization:** Refactored utilities into =utils-org= and =utils-lisp= for predictable discovery.
|
||||
- **Autonomous Mandates:** Implemented =GEMINI.md= for local agentic enforcement of engineering standards.
|
||||
- **Onboarding Wizard:** Modular Lisp setup for multiple LLM providers.
|
||||
- **Professional TUI:** Styled, scrollable interface with improved diagnostics.
|
||||
|
||||
* v0.1.0 - The Autonomous Foundation (2026-04-20)
|
||||
This is the initial MVP release of the ~opencortex~. It establishes a secure, auditable Lisp kernel for a personal operating system.
|
||||
|
||||
** Features
|
||||
- **Unified Envelope Architecture:** Actuator-agnostic protocol that decouples routing metadata from cognitive payloads, ensuring all clients (TUI, Emacs, CLI, Matrix) are treated as equal citizens.
|
||||
- **Metabolic Pipeline:** Robust Perceive-Reason-Act loop with selective memory rollbacks and graceful shutdown handling.
|
||||
- **Verification Lock:** Mandatory skill enforcement via environment configuration. System halts if security policies or bouncers fail to load.
|
||||
- **Foveal-Peripheral Context:** High-resolution focus on active tasks with low-resolution skeletal awareness of the rest of the Memex.
|
||||
- **The Bouncer:** Last-mile deterministic security gate with Deep Packet Inspection for secrets and network exfiltration.
|
||||
- **Autonomous Scribe:** Background distillation worker that turns daily journal entries into evergreen Zettelkasten notes. Verified to distill atomic concepts autonomously.
|
||||
- **Autonomous Gardener:** Heartbeat-driven worker that repairs broken links and identifies orphaned nodes in the Memex graph.
|
||||
- **Unified Onboarding:** Single-command installation (~opencortex.sh~) with Docker support, OS detection, and automated dependency resolution.
|
||||
- **Channel-Aware TUI:** Interactive Croatoan-based terminal client with clean, human-readable formatting for tool results and system logs.
|
||||
- **CLI Gateway:** Local TCP socket server for pipe-friendly interaction and frictionless first contact.
|
||||
|
||||
** Licensing & Community
|
||||
- **AGPLv3 License:** OpenCortex is now officially licensed under the GNU Affero General Public License v3.0.
|
||||
- **Contributor License Agreement:** Implemented a broad CLA (~CLA.org~) for long-term project sustainability.
|
||||
|
||||
** Architectural Shift
|
||||
- Transitioned to **Literate Granularity**: Every function and invariant is now formally documented in its own Org block.
|
||||
- **Provider Agnosticism:** Implemented a dynamic LLM cascade (OpenRouter, Ollama, etc.) removing all hardcoded backend dependencies.
|
||||
- **Thin Harness Philosophy:** Decoupled the kernel from specific editors or third-party gateways.
|
||||
@@ -1,44 +1,116 @@
|
||||
#+TITLE: Contributing to OpenCortex
|
||||
#+AUTHOR: OpenCortex Contributors
|
||||
#+TITLE: Contributing to Passepartout
|
||||
#+AUTHOR: Passepartout Contributors
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:contributing:
|
||||
|
||||
* Philosophy
|
||||
OpenCortex is built on a "Zero-Bloat" mandate. The core kernel is mathematically pure, pushing all peripheral logic, API integrations, and routing to hot-reloadable "Skills".
|
||||
Passepartout is built on a "Zero-Bloat" mandate. The core kernel is mathematically pure, pushing all peripheral logic, API integrations, and routing to hot-reloadable "Skills".
|
||||
|
||||
* Literate Granularity
|
||||
We strictly adhere to Literate Programming using Org-mode.
|
||||
- *Never* edit `.lisp` files in `src/` directly.
|
||||
- Modify the corresponding `.org` files in the `literate/` or `skills/` directories.
|
||||
- Run `org-babel-tangle` to generate the source code.
|
||||
- Every architectural decision, constraint, and implementation detail must be documented alongside the code in the `.org` file.
|
||||
* Development Workflow
|
||||
|
||||
The full development cycle is described in ~AGENTS.md~. In summary:
|
||||
|
||||
1. *Think in org* — write reasoning and goals in the .org file
|
||||
2. *Write contract* — define each function's behavior in a ~** Contract~ section
|
||||
3. *TDD from contract* — each contract item becomes a ~fiveam:test~; prove RED then GREEN
|
||||
4. *Reflect in org* — ensure implementation is in .org source
|
||||
5. *Update literate prose* — explain the code: what, why, how it connects
|
||||
|
||||
* Literate Programming
|
||||
|
||||
~.org~ files in ~org/~ are the source of truth. ~lisp/~ files are generated by ~org-babel-tangle~.
|
||||
|
||||
- Never edit =lisp/= files directly — always modify the corresponding =org/= file
|
||||
- All ~#+begin_src lisp~ blocks in a file inherit their tangle destination from the file-level ~#+PROPERTY: header-args:lisp :tangle ../lisp/FILE.lisp~
|
||||
- Every architectural decision, constraint, and implementation detail must be documented alongside the code
|
||||
|
||||
* Contracts and Tests
|
||||
|
||||
Every code change starts with a contract and a failing test. Write a ~** Contract~ section listing each function's behavior, then create a ~fiveam:test~ in the ~* Test Suite~ section for each contract item.
|
||||
|
||||
To run tests for a specific file:
|
||||
|
||||
#+begin_src bash
|
||||
sbcl --noinform \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval '(ql:quickload :passepartout :silent t)' \
|
||||
--eval '(load "lisp/FILE.lisp")' \
|
||||
--eval '(fiveam:run (intern "SUITE-NAME" :passepartout-TESTS))' --quit
|
||||
#+end_src
|
||||
|
||||
No test may be committed without proof it was first run to failure (RED).
|
||||
|
||||
* Skill Creation Standard
|
||||
Skills are the building blocks of OpenCortex. They reside in the `skills/` directory.
|
||||
|
||||
A skill must define:
|
||||
1. *Trigger*: A lambda determining if the skill should activate based on the context.
|
||||
2. *Probabilistic Gate*: Optional. Generates a prompt for the LLM.
|
||||
3. *Deterministic Gate*: A hardcoded Lisp function that guarantees safety or executes side-effects (the "Bouncer" pattern).
|
||||
A skill is a =.org= file in =org/= that defines:
|
||||
|
||||
Example Registration:
|
||||
1. *Contract* — what the skill guarantees
|
||||
2. *Implementation* — the code, tangled to ~lisp/~ via ~#+PROPERTY: header-args:lisp~
|
||||
3. *Skill Registration* — a ~defskill~ form with ~:priority~, ~:trigger~, ~:probabilistic~ / ~:deterministic~
|
||||
4. *Test Suite* — ~fiveam:test~ forms verifying the contract
|
||||
|
||||
Example:
|
||||
#+begin_src lisp
|
||||
(defskill :skill-example
|
||||
(defskill :passepartout-example
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) ...)
|
||||
:probabilistic nil
|
||||
:probabilistic (lambda (ctx) ...)
|
||||
:deterministic (lambda (action ctx) ...))
|
||||
#+end_src
|
||||
|
||||
* The Unified Envelope (Communication Protocol)
|
||||
All inter-process communication occurs via the Unified Envelope. Do not use legacy specific types like `:CHAT`.
|
||||
- Always use semantic types: `:REQUEST`, `:EVENT`, `:RESPONSE`, `:STATUS`, `:LOG`.
|
||||
- Include routing metadata in the `:META` block (e.g., `(:SOURCE :TUI)`).
|
||||
- Ensure generated `:REQUEST` messages include a mandatory `:TARGET` field.
|
||||
* Project Structure
|
||||
|
||||
* Pull Request Process
|
||||
1. Ensure your working tree is clean.
|
||||
2. Write tests for your skill in `tests/`.
|
||||
3. Tangle all files.
|
||||
4. Run the test suite: `sbcl --eval "(asdf:test-system :opencortex)"`.
|
||||
5. Submit a PR outlining the architectural intent and the specific Literate changes.
|
||||
| Directory | Purpose |
|
||||
|----------------------+--------------------------------------------------|
|
||||
| =org/= | Literate source files (edit these) |
|
||||
| =lisp/= | Tangled .lisp output (never edit) |
|
||||
| =docs/= | ROADMAP, ARCHITECTURE, DESIGN_DECISIONS, etc. |
|
||||
| =scripts/= | Build and utility scripts |
|
||||
| ~/.local/share/passepartout/= | XDG data dir — deployed lisp files |
|
||||
| ~/.config/passepartout/= | Config (.env) |
|
||||
|
||||
* Key Libraries
|
||||
|
||||
| Library | Purpose |
|
||||
|------------------+----------------------------------|
|
||||
| Croatoan | TUI (terminal UI) |
|
||||
| usocket | TCP sockets (daemon protocol) |
|
||||
| bordeaux-threads | Threading (reader thread) |
|
||||
| dexador | HTTP client (LLM API calls) |
|
||||
| cl-ppcre | Regex (search-files, dispatcher) |
|
||||
| ironclad | SHA-256 (Merkle hashing) |
|
||||
| hunchentoot | HTTP server |
|
||||
| cl-json | JSON encoding/decoding |
|
||||
|
||||
* Protocol
|
||||
|
||||
All inter-process communication uses the Unified Envelope protocol over TCP (port 9105). Message types: ~:REQUEST~, ~:EVENT~, ~:RESPONSE~, ~:STATUS~, ~:LOG~. Each message includes a ~:META~ block with routing metadata.
|
||||
|
||||
* Pre-Commit Hook
|
||||
|
||||
Validates staged org files by tangling + structural-checking:
|
||||
#+begin_src bash
|
||||
ln -sf ../../scripts/pre-commit-repl-check .git/hooks/pre-commit
|
||||
#+end_src
|
||||
Runs automatically on ~git commit~.
|
||||
|
||||
* Testing Tools
|
||||
|
||||
** TUI REPL (~/eval~)
|
||||
The TUI has a built-in command for live evaluation:
|
||||
- ~/eval (+ 1 2)~ → result displayed in chat window
|
||||
- ~/eval (add-msg :system "test")~ → inject a test message
|
||||
|
||||
** Tmux (TUI integration testing)
|
||||
#+begin_src bash
|
||||
tmux new-session -d -s test "passepartout tui 2>&1 | tee /tmp/tui.log"
|
||||
tmux send-keys -t test "hello world" Enter
|
||||
tmux capture-pane -t test -p -S -200
|
||||
tmux kill-session -t test
|
||||
#+end_src
|
||||
|
||||
** Swank (Emacs REPL for TUI)
|
||||
1. Start TUI: ~passepartout tui~
|
||||
2. In Emacs: ~M-x slime-connect RET 127.0.0.1 RET 4006~
|
||||
3. ~C-M-x~ any form from =org/gateway-tui.org= → evaluates in live TUI process
|
||||
4. Configure port: ~export TUI_SWANK_PORT=4009~ (default: 4006)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
1779
docs/ROADMAP.org
1779
docs/ROADMAP.org
File diff suppressed because it is too large
Load Diff
@@ -1,28 +1,21 @@
|
||||
#+TITLE: OpenCortex User Manual
|
||||
#+AUTHOR: OpenCortex Contributors
|
||||
#+TITLE: Passepartout User Manual
|
||||
#+AUTHOR: Passepartout Contributors
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:manual:
|
||||
|
||||
* Introduction
|
||||
Welcome to OpenCortex v0.1.0 (The Autonomous Foundation). OpenCortex is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
Welcome to Passepartout. Passepartout is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
|
||||
* Installation
|
||||
OpenCortex is bootstrapped via a single shell script.
|
||||
Passepartout is bootstrapped via a single shell script.
|
||||
|
||||
** Quick start (curl)
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/opencortex/main/opencortex.sh | bash -s configure
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout | bash -s configure
|
||||
#+end_src
|
||||
|
||||
** From a clone
|
||||
|
||||
#+begin_src bash
|
||||
git clone https://github.com/amrgharbeia/opencortex.git ~/projects/opencortex
|
||||
~/projects/opencortex/opencortex.sh configure
|
||||
#+end_src
|
||||
|
||||
Both methods will:
|
||||
This will:
|
||||
1. Install system dependencies (SBCL, Emacs, git, curl, socat — detected for Debian or Fedora)
|
||||
2. Install Quicklisp (Common Lisp package manager)
|
||||
3. Tangle literate Org sources into runnable Lisp
|
||||
@@ -31,42 +24,348 @@ Both methods will:
|
||||
If you already have Emacs installed, the installer skips it and uses your existing installation.
|
||||
|
||||
* Configuration
|
||||
The system is configured via a `.env` file in the project root. Essential variables include:
|
||||
The system is configured via a ~.env~ file in the project root. Essential variables include:
|
||||
|
||||
- `OPENROUTER_API_KEY`: Your LLM provider key.
|
||||
- `PROVIDER_CASCADE`: The fallback order for LLM providers (e.g., `openrouter,ollama,anthropic`).
|
||||
- `MEMEX_DIR`: The absolute path to your knowledge base (defaults to `~/memex`).
|
||||
- ~OPENROUTER_API_KEY~: Your LLM provider key.
|
||||
- ~PROVIDER_CASCADE~: The fallback order for LLM providers (e.g., ~openrouter,ollama,anthropic~).
|
||||
- ~MEMEX_DIR~: The absolute path to your knowledge base (defaults to ~/memex~).
|
||||
|
||||
* Interacting with OpenCortex
|
||||
* Interacting with Passepartout
|
||||
Because of the Unified Envelope Architecture, the kernel treats all clients as interchangeable. You must first boot the background daemon:
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh --boot &
|
||||
./passepartout --boot &
|
||||
#+end_src
|
||||
|
||||
** Terminal User Interface (TUI)
|
||||
For a rich, split-pane terminal experience:
|
||||
#+begin_src bash
|
||||
./opencortex.sh tui
|
||||
./passepartout tui
|
||||
#+end_src
|
||||
|
||||
** Command Line Interface (CLI)
|
||||
For raw, pipe-friendly interaction:
|
||||
#+begin_src bash
|
||||
./opencortex.sh cli
|
||||
./passepartout cli
|
||||
#+end_src
|
||||
|
||||
** Emacs Integration
|
||||
OpenCortex functions as your "foveal vision" inside Emacs.
|
||||
1. Ensure `org-agent.el` is loaded.
|
||||
2. Run `M-x opencortex-connect`.
|
||||
3. Interact via the `*opencortex-chat*` buffer.
|
||||
** TUI Commands
|
||||
|
||||
When connected via the TUI, the following commands are available (type them in the input area and press Enter):
|
||||
|
||||
| Command | Action |
|
||||
|-----------------------+--------------------------------------------------------|
|
||||
| ~/help~ | List all available commands |
|
||||
| ~/focus <project>~ | Set the agent's foveal focus to a project by name |
|
||||
| ~/scope memex~ | Set scope to full memex (all projects visible) |
|
||||
| ~/scope session~ | Set scope to current session only |
|
||||
| ~/scope project~ | Set scope to focused project only |
|
||||
| ~/unfocus~ | Clear the foveal focus |
|
||||
| ~/approve HITL-xxxx~ | Approve a pending HITL action by its token |
|
||||
| ~/deny HITL-xxxx~ | Deny a pending HITL action by its token |
|
||||
| ~/theme <name>~ | Switch theme (dark, light, solarized, gruvbox) |
|
||||
| ~/cost~ | Toggle session cost display in status bar |
|
||||
| ~/voice on~ | Enable voice capture (planned v0.7.3) |
|
||||
| ~/voice off~ | Disable voice capture |
|
||||
| ~/quit~ | Save history and exit (planned v0.3.3) |
|
||||
|
||||
For multi-line input, start the line with ~\~ then press Enter to insert a newline without sending.
|
||||
|
||||
** Human-in-the-Loop Approval
|
||||
|
||||
When the Dispatcher blocks a high-risk action (shell command, network call, core file modification), it creates a Flight Plan requiring your approval.
|
||||
|
||||
1. The TUI displays a yellow message: ~→ HITL required: /approve HITL-ab12~
|
||||
2. Review the proposed action in the Dispatcher trace (expand with Tab)
|
||||
3. Type ~/approve HITL-ab12~ to approve, or ~/deny HITL-ab12~ to deny
|
||||
4. Approved actions are re-injected into the pipeline and executed
|
||||
5. Denied actions are discarded and the Dispatcher records the decision as a permanent rule
|
||||
|
||||
Each approval or denial teaches the Dispatcher — the rule counter in the status bar (~[Rules: 47]~) increments with every decision.
|
||||
|
||||
* The Memex Structure
|
||||
OpenCortex assumes a local folder structure representing your "Memex".
|
||||
Passepartout assumes a local folder structure representing your "Memex".
|
||||
- Core memories and identities are mapped to Org-mode files.
|
||||
- The `Scribe` background worker distills chronological logs into structured Zettelkasten notes.
|
||||
- The `Gardener` continuously repairs broken links and flags orphaned nodes.
|
||||
- The ~Scribe~ background worker distills chronological logs into structured Zettelkasten notes.
|
||||
- The ~Gardener~ continuously repairs broken links and flags orphaned nodes.
|
||||
|
||||
* How Safety Works
|
||||
|
||||
Passepartout enforces safety through ten deterministic gates. Every action the agent wants to take — reading a file, running a shell command, sending network traffic — passes through these gates before execution. Critically, all ten gates are pure Lisp functions: they cost zero LLM tokens to evaluate. Safety checking never touches your provider budget.
|
||||
|
||||
** The Ten Safety Gates
|
||||
|
||||
| Gate | What It Checks |
|
||||
|------+----------------|
|
||||
| Lisp syntax | Validates that any Lisp code is well-formed before evaluation |
|
||||
| Secret file paths | Blocks reads from known secret directories (~.ssh~, ~.env~, ~.aws~, etc.) |
|
||||
| Self-build core | Prevents modification of the agent's own source and build files |
|
||||
| Secret content | Scans text output for API keys, tokens, or credential patterns |
|
||||
| Vault secrets | Guards any secret stored in the encrypted vault |
|
||||
| Privacy tags | Respects ~@privacy:~ annotations on memory objects and files |
|
||||
| Privacy text leaks | Scans outgoing text for PII (emails, phone numbers, addresses) |
|
||||
| Shell safety | Blocks destructive commands (~rm -rf~, ~:(){:|:&};:~, ~mkfs~, ~dd~) |
|
||||
| Network exfiltration | Blocks outbound traffic carrying private data to unknown hosts |
|
||||
| High-impact actions | Catches system-level changes (package installs, service restarts, mount) |
|
||||
|
||||
** Severity Tiers
|
||||
|
||||
Each gate assigns a severity to the action it inspects:
|
||||
|
||||
| Severity | Behavior |
|
||||
|------------+-------------------------------------------------------|
|
||||
| Catastrophic | Always blocked. No approval possible. |
|
||||
| Dangerous | Requires HITL approval. Generates a Flight Plan. |
|
||||
| Moderate | Allowed, but logged. The agent learns from the outcome. |
|
||||
| Harmless | Always allowed. No logging overhead. |
|
||||
|
||||
** What Happens When an Action Is Blocked
|
||||
|
||||
When a gate blocks an action, the Dispatcher creates a Flight Plan — a structured record of what the agent wants to do, why it was blocked, and which gate triggered. The Flight Plan is presented to you for review. You can approve it (~/approve~), deny it (~/deny~), or ask the agent to clarify its intent (~/clarify~). Once you approve, the action executes immediately. Once you deny, the Dispatcher records the decision as a permanent rule and will never propose that action again.
|
||||
|
||||
* Understanding Context and Focus
|
||||
|
||||
Passepartout uses a foveal-peripheral context model, inspired by human vision. This is how the agent decides what to pay attention to in your Memex.
|
||||
|
||||
** The Three Levels of Attention
|
||||
|
||||
- ~/foveal/~ — What the agent reads deeply and reasons about right now. Anything you explicitly mention, plus the current focused project.
|
||||
- ~/peripheral/~ — What the agent knows exists (titles, summaries, metadata) but does not read in detail. Everything in scope.
|
||||
- ~/blind/~ — Outside scope. The agent cannot see or access it.
|
||||
|
||||
** Focus Commands
|
||||
|
||||
| Command | Effect |
|
||||
|---------------------+---------------------------------------------------------|
|
||||
| ~/focus <project>~ | Set the agent's foveal attention to a project |
|
||||
| ~/scope memex~ | Expand scope to everything in your Memex |
|
||||
| ~/scope session~ | Narrow scope to just the current conversation |
|
||||
| ~/scope project~ | Narrow scope to the focused project only |
|
||||
| ~/unfocus~ | Clear the foveal focus; the agent sees everything at peripheral level |
|
||||
|
||||
** The Focus Map
|
||||
|
||||
The status bar displays a focus map — a compact representation of what the agent is "looking at." Projects in foveal view are highlighted; peripheral projects are dimmed. When you change focus, the map updates in real time so you always know the agent's current attention budget.
|
||||
|
||||
* Skills and What They Do
|
||||
|
||||
Skills are hot-reloadable modules that extend the agent's capabilities. Unlike core system files, a bug in a skill degrades the agent but does not kill it — skills can be repaired by the agent itself. Skills are organized into categories by function:
|
||||
|
||||
** Core Pipeline
|
||||
The agent's cognitive loop: Perceive (consume input) → Reason (think with the LLM) → Act (execute tools). This is the central nervous system of the agent.
|
||||
|
||||
** Security
|
||||
~Dispatcher~, ~Policy~, ~Permissions~, ~Validator~, ~Vault~. These skills enforce the safety gates, manage approval workflows, encrypt secrets, and verify that every action conforms to the rules you have set.
|
||||
|
||||
** Channels
|
||||
~TUI~, ~CLI~, ~Telegram~, ~Signal~, ~Discord~, ~Slack~, ~Shell~. Each channel is a separate skill that handles I/O for a specific interface. All channels are equal citizens — the agent treats a message from Telegram identically to one typed in the TUI.
|
||||
|
||||
** Programming
|
||||
~Lisp~, ~Org~, literate tools, ~REPL~, standards libraries. These skills allow the agent to write, evaluate, and reason about Lisp code, manage Org-mode documents, and tangle literate programs into runnable source.
|
||||
|
||||
** Symbolic
|
||||
~Awareness~, ~Scope~, ~Events~, ~Config~, ~Memory~, ~Identity~, ~Time~. These skills manage the agent's internal state: what it knows about itself, what it remembers, how it configures its behavior, and how it tracks time and events.
|
||||
|
||||
** Neuro
|
||||
~Provider~, ~Router~, ~Explorer~. These skills manage the LLM backends. The Provider skill abstracts each LLM API; the Router decides which provider to use based on cost, latency, and availability; the Explorer discovers new providers.
|
||||
|
||||
** Embedding
|
||||
Backends for semantic search and native inference. These skills enable the agent to embed text, search your Memex by meaning rather than exact keyword, and run local inference without network calls.
|
||||
|
||||
** Economics
|
||||
~Tokenizer~, ~Cost Tracker~, ~Token Economics~. These skills count tokens, estimate costs before making LLM calls, track spending across providers, and enforce budget limits.
|
||||
|
||||
* The Tool System
|
||||
|
||||
The agent has ten cognitive tools — discrete actions it can take to interact with your environment. Each tool maps to a specific capability.
|
||||
|
||||
** Read-Only Tools
|
||||
|
||||
| Tool | What It Does |
|
||||
|-------------------+---------------------------------------------|
|
||||
| ~search-files~ | Search file contents with regex patterns |
|
||||
| ~find-files~ | Find files by name using glob patterns |
|
||||
| ~read-file~ | Read the contents of a file on disk |
|
||||
| ~list-directory~ | List the contents of a directory |
|
||||
| ~org-find-headline~ | Find a headline in an Org-mode file |
|
||||
|
||||
** Write Tools
|
||||
|
||||
| Tool | What It Does |
|
||||
|-------------------+---------------------------------------------|
|
||||
| ~write-file~ | Create or overwrite a file on disk |
|
||||
| ~org-modify-file~ | Modify an Org-mode file structurally |
|
||||
| ~run-shell~ | Execute a shell command |
|
||||
| ~eval-form~ | Evaluate a Lisp expression |
|
||||
| ~run-tests~ | Execute a test suite |
|
||||
|
||||
** Auto-Approval
|
||||
|
||||
Write tools are subject to safety-gate inspection. Read-only tools are auto-approved by default (though the agent still checks for secret-file reads). You can configure per-tool auto-approval in your ~.env~ file with the ~AUTO_APPROVE_TOOLS~ variable:
|
||||
|
||||
#+begin_src bash
|
||||
# Auto-approve read-file and find-files (default)
|
||||
AUTO_APPROVE_TOOLS=read-file,find-files,list-directory,search-files
|
||||
#+end_src
|
||||
|
||||
* Cost Tracking
|
||||
|
||||
Every LLM call costs tokens, and tokens cost money. Passepartout tracks this transparently.
|
||||
|
||||
** Token Budgets
|
||||
|
||||
Set ~CONTEXT_MAX_TOKENS~ in your ~.env~ file to cap the total context window the agent may use per interaction:
|
||||
|
||||
#+begin_src bash
|
||||
CONTEXT_MAX_TOKENS=128000
|
||||
#+end_src
|
||||
|
||||
The agent will truncate older context rather than exceed this limit.
|
||||
|
||||
** Per-Call Cost Tracking
|
||||
|
||||
Before every LLM call, the Economics skill estimates the cost (prompt tokens + expected completion tokens) and checks it against your budget. After the call, it records actual usage. The status bar shows your session total.
|
||||
|
||||
** The ~/cost~ Command
|
||||
|
||||
Toggle cost display in the status bar with ~/cost~. When enabled, you'll see a running total like ~[$0.047]~ showing the estimated cost of the current session.
|
||||
|
||||
** Per-Provider Pricing
|
||||
|
||||
Different providers charge different rates. The Router skill is aware of this and will choose the cheapest viable provider for each call unless you pin a specific provider:
|
||||
|
||||
#+begin_src bash
|
||||
# Pin to a specific provider
|
||||
PROVIDER_CASCADE=anthropic
|
||||
#+end_src
|
||||
|
||||
** Prompt Prefix Caching
|
||||
|
||||
Providers that support prefix caching (Claude via Anthropic, some OpenRouter models) automatically benefit from it. The agent reuses the system prompt prefix across calls, and the Economics skill tracks the cache-hit savings separately in the cost breakdown.
|
||||
|
||||
* Session Control
|
||||
|
||||
Passepartout maintains a session history with checkpointed memory snapshots. You can move backward and forward through your session state.
|
||||
|
||||
** Undo and Redo
|
||||
|
||||
| Command | Effect |
|
||||
|--------------+----------------------------------------------------------|
|
||||
| ~/undo~ | Restore the memory to the state before your last action |
|
||||
| ~/redo~ | Re-apply the last undone action |
|
||||
| ~/rewind <n>~ | Restore the memory to the state n actions ago |
|
||||
|
||||
** What Gets Restored
|
||||
|
||||
A session rewind restores three things: file changes (files written or modified are reverted), memory objects (the agent's internal knowledge), and TODO states (the roadmap and task tracking). This means you can safely let the agent explore and experiment — if it goes down a wrong path, rewind and redirect.
|
||||
|
||||
* Gate Trace Reference
|
||||
|
||||
Below every agent message in the TUI, you'll see colored lines representing the safety-gate trace for that message. These show you exactly which gates ran on the agent's actions and what happened.
|
||||
|
||||
| Symbol | Meaning |
|
||||
|--------+------------------------------------------------------------|
|
||||
| ~✓~ | Green — the gate passed. The action was allowed. |
|
||||
| ~✗~ | Red — the gate blocked the action. The reason is shown. |
|
||||
| ~→~ | Yellow — HITL approval required. A Flight Plan is pending. |
|
||||
|
||||
Press ~Ctrl+G~ to toggle gate trace visibility on and off. The most recent gate trace for your last interaction is always available via the ~/why~ command — type ~/why~ and the agent will display the full trace with explanations.
|
||||
|
||||
* Tag System
|
||||
|
||||
Passepartout uses an Org-mode tag system to annotate and control behavior. Tags are metadata appended to headlines and memory objects.
|
||||
|
||||
** Severity Tags
|
||||
|
||||
The ~@tag:severity~ tier controls how strictly the safety system handles a tagged item:
|
||||
|
||||
| Tag | Behavior |
|
||||
|------------------+--------------------------------------------------------------|
|
||||
| ~@tag:block~ | The tagged item is treated as catastrophic — always blocked |
|
||||
| ~@tag:warn~ | The tagged item triggers HITL approval when accessed |
|
||||
| ~@tag:log~ | Access is allowed but logged for audit |
|
||||
|
||||
** Tag Categories
|
||||
|
||||
Configure which tags trigger which behavior with the ~TAG_CATEGORIES~ environment variable:
|
||||
|
||||
#+begin_src bash
|
||||
TAG_CATEGORIES=block:warn:log
|
||||
#+end_src
|
||||
|
||||
** The ~/tags~ Command
|
||||
|
||||
Type ~/tags~ to list all tags currently active in the agent's scope, along with their severity levels and the files or memory objects they apply to.
|
||||
|
||||
* HITL Deep Dive
|
||||
|
||||
When the Safety system blocks an action, a structured workflow begins. Understanding this workflow helps you make informed approval decisions quickly.
|
||||
|
||||
** The Flight Plan Lifecycle
|
||||
|
||||
1. /Trigger/: A gate rates an action Dangerous or Catastrophic, or a ~@tag:warn~ tag is encountered.
|
||||
2. /Plan/: The Dispatcher serializes the proposed action into a Flight Plan: what tool, what arguments, what file or command, which gate triggered.
|
||||
3. /Display/: The TUI shows a yellow prompt with the Flight Plan token (~HITL-ab12~).
|
||||
4. /Review/: Press ~Tab~ to expand the gate trace and see the full Flight Plan details.
|
||||
5. /Decision/: You type ~/approve HITL-ab12~ or ~/deny HITL-ab12~.
|
||||
6. /Execute or Discard/: Approved plans execute immediately. Denied plans are discarded.
|
||||
7. /Learn/: The Dispatcher increments its rule counter and records the decision as a permanent rule. If you denied an action, the Dispatcher will never propose it again.
|
||||
|
||||
** Clarifying Questions
|
||||
|
||||
If you are unsure why the agent wants to perform an action, you can ignore the Flight Plan prompt. After three retries without a decision, the agent escalates by injecting a ~/clarify~ message into the pipeline, asking the agent to explain its intent in plain language. You can then approve or deny with full context.
|
||||
|
||||
** The Rule Counter
|
||||
|
||||
The status bar shows ~[Rules: N]~ — the number of permanent rules the Dispatcher has learned from your decisions. Each approval or denial is a learning event. Over time, the Dispatcher builds a personalized safety profile that reflects your preferences: which actions you always approve, which you always deny, and which you want to review case by case.
|
||||
|
||||
* TUI Keybinding Reference
|
||||
|
||||
The TUI supports a rich set of keyboard shortcuts for efficient interaction.
|
||||
|
||||
** Editing Keys
|
||||
|
||||
| Combo | Action |
|
||||
|-----------+-------------------------------------------|
|
||||
| ~Ctrl+D~ | Quit the TUI |
|
||||
| ~Ctrl+U~ | Clear the current input line |
|
||||
| ~Ctrl+W~ | Delete the word before the cursor |
|
||||
| ~Ctrl+A~ | Move cursor to beginning of line (Home) |
|
||||
| ~Ctrl+E~ | Move cursor to end of line |
|
||||
| ~Ctrl+K~ | Delete from cursor to end of line |
|
||||
| ~Ctrl+L~ | Redraw the screen |
|
||||
| ~Ctrl+X+E~ | Open the current input in your external editor (~$EDITOR~) |
|
||||
| ~Tab~ | Autocomplete commands, themes, and file paths |
|
||||
|
||||
** Navigation and Control
|
||||
|
||||
| Combo | Action |
|
||||
|------------------+--------------------------------------------------|
|
||||
| ~Ctrl+C~ | Interrupt (cascade: stop streaming → stop thinking → quit) |
|
||||
| ~Ctrl+F~ | Search through message history |
|
||||
| ~Ctrl+P~ | Open the command palette |
|
||||
| ~Ctrl+G~ | Toggle gate trace visibility |
|
||||
| ~Ctrl+X+B~ | Toggle the sidebar (focus map, memory browser) |
|
||||
| ~Page Up~ | Scroll chat up by 10 lines |
|
||||
| ~Page Down~ | Scroll chat down by 10 lines |
|
||||
| ~Up Arrow~ | Previous input in command history |
|
||||
| ~Down Arrow~ | Next input in command history |
|
||||
|
||||
** The Status Bar
|
||||
|
||||
The status bar at the bottom of the TUI shows the agent's current state at a glance. Each indicator has a specific meaning:
|
||||
|
||||
| Indicator | Meaning |
|
||||
|------------------+--------------------------------------------------------------------|
|
||||
| ~[Connected]~ | Green — daemon is reachable on port 9105. Gray — disconnected. |
|
||||
| ~[Mode: TUI]~ | The current interaction mode (TUI, CLI, Telegram, etc.) |
|
||||
| ~[Msg: 142]~ | Total messages in the current session |
|
||||
| ~[↑ 12]~ | Scroll indicator — you are scrolled up 12 lines from the bottom |
|
||||
| ~[◉]~ | Activity spinner — spinning means the agent is working |
|
||||
| ~[⟳]~ | Streaming indicator — shown while the agent is generating text |
|
||||
| ~[$0.047]~ | Session cost (visible when ~/cost~ is toggled on) |
|
||||
| ~[Rules: 52]~ | Number of permanent HITL rules learned from your decisions |
|
||||
| ~[prj:my-proj]~ | Current focused project name |
|
||||
|
||||
* Deployment
|
||||
|
||||
@@ -75,25 +374,39 @@ OpenCortex assumes a local folder structure representing your "Memex".
|
||||
The ~configure~ command supports both Debian-based (Ubuntu, Pop, Mint) and Fedora-based (RHEL, Rocky) distributions. It detects your distro automatically and installs the correct packages.
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh configure # interactive
|
||||
./opencortex.sh configure --non-interactive # headless
|
||||
./opencortex.sh configure --with-firewall # also open port 9105
|
||||
./passepartout configure # interactive
|
||||
./passepartout configure --non-interactive # headless
|
||||
./passepartout configure --with-firewall # also open port 9105
|
||||
#+end_src
|
||||
|
||||
After configuration, you can re-run ~configure~ any time to add providers or link gateways.
|
||||
|
||||
** Binary install (save-lisp-and-die)
|
||||
|
||||
For platforms where SBCL cannot be installed (corporate laptops, shared hosts, constrained environments), a self-contained binary is provided:
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://github.com/amrgharbeia/passepartout/releases/latest/download/passepartout -o passepartout
|
||||
chmod +x passepartout
|
||||
./passepartout daemon
|
||||
#+end_src
|
||||
|
||||
This binary bundles SBCL, all required Lisp code, native embedding inference, and a Swank server on port 4005. The experience is identical to a source install — the REPL is available, skills hot-reload, and the image is mutable. Memory survives snapshots.
|
||||
|
||||
The binary is a convenience for constrained platforms. It is not a sealed container. The system remains constitutionally open — connect with SLIME, trace functions, inspect memory objects, modify the system while it runs.
|
||||
|
||||
** systemd service (auto-start on boot)
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh install service
|
||||
./passepartout install service
|
||||
#+end_src
|
||||
|
||||
Installs a user-level systemd unit that starts the daemon on login. Logs are available via ~journalctl --user -u opencortex.service -f~.
|
||||
Installs a user-level systemd unit that starts the daemon on login. Logs are available via ~journalctl --user -u passepartout.service -f~.
|
||||
|
||||
To remove:
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh uninstall service
|
||||
./passepartout uninstall service
|
||||
#+end_src
|
||||
|
||||
** Docker
|
||||
@@ -110,7 +423,7 @@ This builds an image from ~debian:trixie-slim~ with all dependencies pre-install
|
||||
** Backup
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh backup ~/my-backup.tar.gz
|
||||
./passepartout backup ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Backs up the config, data, and memex directories.
|
||||
@@ -118,7 +431,31 @@ Backs up the config, data, and memex directories.
|
||||
** Restore
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh restore ~/my-backup.tar.gz
|
||||
./passepartout restore ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Restores from a backup file. Run ~opencortex doctor~ afterward to verify integrity.
|
||||
Restores from a backup file. Run ~passepartout doctor~ afterward to verify integrity.
|
||||
|
||||
* Troubleshooting
|
||||
|
||||
** The daemon won't start
|
||||
- Check SBCL is installed: ~which sbcl~
|
||||
- Run ~passepartout doctor~ to diagnose
|
||||
- Check port 9105 is free: ~lsof -i :9105~
|
||||
- Check the log output for errors
|
||||
|
||||
** The TUI connects but shows "Disconnected"
|
||||
- The daemon may have crashed. Run ~passepartout daemon~ in another terminal
|
||||
- If the daemon is running, check it's listening: ~lsof -i :9105~
|
||||
- Use ~/reconnect~ (planned v0.6.0) to reconnect without restarting the TUI
|
||||
|
||||
** The LLM returns garbage or fails to respond
|
||||
- Run ~passepartout doctor~ to verify your LLM provider keys
|
||||
- Check ~PROVIDER_CASCADE~ in your ~.env~ file
|
||||
- Try switching models: edit ~.env~ and restart the daemon
|
||||
- If using local models via Ollama, verify Ollama is running: ~ollama list~
|
||||
|
||||
** Memory fails to load on startup
|
||||
- Check ~/memory.snap~ exists and is valid S-expression format
|
||||
- Run ~passepartout doctor~ to diagnose memory integrity
|
||||
- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory
|
||||
|
||||
214
extras/passepartout.el
Normal file
214
extras/passepartout.el
Normal file
@@ -0,0 +1,214 @@
|
||||
;;; passepartout.el --- Emacs bridge for Passepartout AI assistant -*- lexical-binding: t; -*-
|
||||
|
||||
;; Author: Passepartout Project
|
||||
;; Version: 0.4.0
|
||||
;; Keywords: tools, processes, lisp
|
||||
;; URL: https://github.com/amrgharbeia/passepartout
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Connects to the Passepartout daemon on localhost:9105 via TCP.
|
||||
;; Speaks the framed plist protocol — 6-character hex length prefix
|
||||
;; followed by a prin1'd S-expression — identical to the TUI and CLI.
|
||||
;; The daemon does not know or care whether the client is the Croatoan
|
||||
;; TUI, the CLI, or Emacs.
|
||||
|
||||
;; Framed protocol (per core-communication.org):
|
||||
;; SEND: 6-char hex length + prin1'd plist
|
||||
;; RECV: read 6-char header → parse hex length → read N bytes →
|
||||
;; read-from-string (with read-eval nil on daemon side)
|
||||
|
||||
;; Usage:
|
||||
;; M-x passepartout RET — connect to daemon, open response buffer
|
||||
;; M-x passepartout-send-region — send selected region as user-input
|
||||
;; M-x passepartout-send-buffer — send entire buffer
|
||||
;; M-x passepartout-disconnect — close connection
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(defgroup passepartout nil
|
||||
"Emacs bridge for Passepartout AI assistant."
|
||||
:group 'applications)
|
||||
|
||||
(defcustom passepartout-host "127.0.0.1"
|
||||
"Host where the Passepartout daemon is running."
|
||||
:type 'string
|
||||
:group 'passepartout)
|
||||
|
||||
(defcustom passepartout-port 9105
|
||||
"Port where the Passepartout daemon is listening."
|
||||
:type 'integer
|
||||
:group 'passepartout)
|
||||
|
||||
(defvar passepartout-process nil
|
||||
"Network process for the Passepartout connection.")
|
||||
|
||||
(defvar passepartout--buffer ""
|
||||
"Accumulation buffer for partial framed messages.")
|
||||
|
||||
(defvar passepartout-response-buffer-name "*passepartout*"
|
||||
"Name of the buffer where daemon responses are rendered.")
|
||||
|
||||
;;;###autoload
|
||||
(defun passepartout ()
|
||||
"Connect to the Passepartout daemon and open the response buffer."
|
||||
(interactive)
|
||||
(unless (and passepartout-process (process-live-p passepartout-process))
|
||||
(setq passepartout-process
|
||||
(make-network-process
|
||||
:name "passepartout"
|
||||
:host passepartout-host
|
||||
:service passepartout-port
|
||||
:filter #'passepartout--filter
|
||||
:sentinel #'passepartout--sentinel
|
||||
:coding 'utf-8-unix
|
||||
:noquery t))
|
||||
(setq passepartout--buffer ""))
|
||||
(switch-to-buffer (get-buffer-create passepartout-response-buffer-name))
|
||||
(passepartout-response-mode)
|
||||
(message "Passepartout: connecting to %s:%d..." passepartout-host passepartout-port))
|
||||
|
||||
(defun passepartout-disconnect ()
|
||||
"Disconnect from the Passepartout daemon."
|
||||
(interactive)
|
||||
(when passepartout-process
|
||||
(delete-process passepartout-process)
|
||||
(setq passepartout-process nil
|
||||
passepartout--buffer "")
|
||||
(message "Passepartout: disconnected.")))
|
||||
|
||||
;;; Protocol: framing
|
||||
|
||||
(defun passepartout--frame-message (msg)
|
||||
"Serialize MSG as a framed plist: 6-char hex length + prin1 output."
|
||||
(let* ((payload (prin1-to-string msg))
|
||||
(len (string-bytes payload)))
|
||||
(format "%06x%s" len payload)))
|
||||
|
||||
(defun passepartout--send (msg)
|
||||
"Send a framed message to the daemon."
|
||||
(when (and passepartout-process (process-live-p passepartout-process))
|
||||
(process-send-string passepartout-process (passepartout--frame-message msg))))
|
||||
|
||||
;;; Protocol: receive
|
||||
|
||||
(defun passepartout--filter (proc string)
|
||||
"Accumulate data and extract complete framed messages."
|
||||
(setq passepartout--buffer (concat passepartout--buffer string))
|
||||
(while (>= (length passepartout--buffer) 6)
|
||||
(let* ((hex-len (substring passepartout--buffer 0 6))
|
||||
(len (condition-case nil
|
||||
(string-to-number hex-len 16)
|
||||
(error nil))))
|
||||
(if (not len)
|
||||
(progn
|
||||
(setq passepartout--buffer (substring passepartout--buffer 1))
|
||||
(message "Passepartout: invalid frame header, skipping byte"))
|
||||
(let ((total-needed (+ 6 len)))
|
||||
(if (>= (length passepartout--buffer) total-needed)
|
||||
(let* ((payload-str (substring passepartout--buffer 6 total-needed))
|
||||
(msg (condition-case nil
|
||||
(read-from-string payload-str)
|
||||
(error nil))))
|
||||
(setq passepartout--buffer (substring passepartout--buffer total-needed))
|
||||
(when msg
|
||||
(passepartout--handle-message msg)))
|
||||
;; Need more data, wait for next chunk
|
||||
(setq passepartout--buffer passepartout--buffer)))))))
|
||||
|
||||
(defun passepartout--sentinel (proc event)
|
||||
"Handle connection state changes."
|
||||
(when (string-match-p "closed\\|failed" event)
|
||||
(setq passepartout-process nil
|
||||
passepartout--buffer "")
|
||||
(with-current-buffer (get-buffer-create passepartout-response-buffer-name)
|
||||
(let ((inhibit-read-only t))
|
||||
(goto-char (point-max))
|
||||
(insert (format "* Connection lost: %s\n\n" event))))
|
||||
(message "Passepartout: connection lost (%s)" event)))
|
||||
|
||||
;;; Message handling
|
||||
|
||||
(defun passepartout--handle-message (msg)
|
||||
"Process a parsed daemon message and render in the response buffer."
|
||||
(with-current-buffer (get-buffer-create passepartout-response-buffer-name)
|
||||
(let ((inhibit-read-only t)
|
||||
(payload (when (listp msg) (plist-get msg :PAYLOAD)))
|
||||
(gate-trace (when (listp msg) (plist-get msg :GATE-TRACE))))
|
||||
(goto-char (point-max))
|
||||
(cond
|
||||
;; Agent text response
|
||||
((and payload (plist-get payload :TEXT))
|
||||
(insert (format "* Agent [%s]\n%s\n"
|
||||
(format-time-string "%H:%M")
|
||||
(plist-get payload :TEXT)))
|
||||
(when gate-trace
|
||||
(passepartout--render-gate-trace gate-trace))
|
||||
(insert "\n"))
|
||||
;; Handshake
|
||||
((and payload (eq (plist-get payload :ACTION) :HANDSHAKE))
|
||||
(insert (format "* Connected to Passepartout v%s\n\n"
|
||||
(or (plist-get payload :VERSION) "?"))))
|
||||
;; Rule count / foveal update — display in mode line
|
||||
((and payload (plist-get payload :RULE-COUNT))
|
||||
(setq passepartout-rule-count (plist-get payload :RULE-COUNT))
|
||||
(force-mode-line-update))
|
||||
;; Fallback: dump raw
|
||||
(t
|
||||
(insert (format "* [%s] %s\n\n"
|
||||
(format-time-string "%H:%M")
|
||||
(prin1-to-string msg))))))))
|
||||
|
||||
(defvar passepartout-rule-count 0
|
||||
"Number of pending HITL rules from the Dispatcher.")
|
||||
|
||||
(defun passepartout--render-gate-trace (trace)
|
||||
"Render the gate trace as property drawer entries."
|
||||
(insert ":PROPERTIES:\n")
|
||||
(dolist (entry trace)
|
||||
(when (listp entry)
|
||||
(let ((gate (plist-get entry :GATE))
|
||||
(result (plist-get entry :RESULT)))
|
||||
(insert (format ":GATE: %s — %s\n"
|
||||
(if gate (symbol-name gate) "?")
|
||||
(symbol-name result))))))
|
||||
(insert ":END:\n"))
|
||||
|
||||
;;; Interactive commands
|
||||
|
||||
(defun passepartout-send-region (beg end)
|
||||
"Send the selected region as user input to Passepartout."
|
||||
(interactive "r")
|
||||
(unless passepartout-process
|
||||
(passepartout))
|
||||
(let ((text (buffer-substring-no-properties beg end)))
|
||||
(passepartout--send (list :TYPE :EVENT
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT text)))
|
||||
(message "Passepartout: sent %d chars" (length text))))
|
||||
|
||||
(defun passepartout-send-buffer ()
|
||||
"Send the entire buffer content as user input to Passepartout."
|
||||
(interactive)
|
||||
(unless passepartout-process
|
||||
(passepartout))
|
||||
(passepartout-send-region (point-min) (point-max)))
|
||||
|
||||
;;; Response buffer mode
|
||||
|
||||
(defvar passepartout-response-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "q") #'quit-window)
|
||||
(define-key map (kbd "g") #'passepartout)
|
||||
map)
|
||||
"Keymap for `passepartout-response-mode'.")
|
||||
|
||||
(define-derived-mode passepartout-response-mode special-mode "Passepartout"
|
||||
"Major mode for viewing Passepartout daemon responses.
|
||||
\\{passepartout-response-mode-map}"
|
||||
(setq buffer-read-only t)
|
||||
(setq-local font-lock-defaults nil))
|
||||
|
||||
(provide 'passepartout)
|
||||
;;; passepartout.el ends here
|
||||
133
harness/act.lisp
133
harness/act.lisp
@@ -1,133 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *default-actuator* :cli
|
||||
"The actuator used when no explicit target is specified.")
|
||||
|
||||
(defvar *silent-actuators* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.")
|
||||
|
||||
(defun initialize-actuators ()
|
||||
"Register core actuators and load configuration."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
(when def
|
||||
(setf *default-actuator* (intern (string-upcase def) :keyword)))
|
||||
(when silent
|
||||
(setf *silent-actuators*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string silent :separator '(#\,))))))
|
||||
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :tool #'execute-tool-action)
|
||||
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((meta (getf action :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
"Route an approved action to its registered actuator."
|
||||
(let ((payload (proto-get action :payload)))
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from dispatch-action nil))
|
||||
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *default-actuator*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(harness-log "ACT ERROR: No actuator registered for '~s'" target))))))
|
||||
|
||||
(defun execute-system-action (action context)
|
||||
"Execute internal harness commands."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :action)))
|
||||
(case cmd
|
||||
(:eval
|
||||
(eval (read-from-string (getf payload :code))))
|
||||
(:message
|
||||
(harness-log "ACT [System]: ~a" (getf payload :text)))
|
||||
(t
|
||||
(harness-log "ACT ERROR [System]: Unknown command '~s'" cmd)))))
|
||||
|
||||
(defun execute-tool-action (action context)
|
||||
"Execute a registered cognitive tool."
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
(when source
|
||||
(dispatch-action (list :TYPE :REQUEST :TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result)))
|
||||
context))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
|
||||
(error (c)
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
|
||||
|
||||
(defun format-tool-result (tool-name result)
|
||||
"Format a tool result for display."
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond
|
||||
((and (eq status :success) content) (format nil "~a" content))
|
||||
((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
|
||||
(defun act-gate (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf feedback verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
(case type
|
||||
(:REQUEST (dispatch-action signal signal))
|
||||
(:LOG (dispatch-action signal signal))
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (dispatch-action approved signal)))
|
||||
(cond
|
||||
((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
((and result (not (member target *silent-actuators*)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))
|
||||
(when source (dispatch-action signal signal)))))
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
187
harness/act.org
187
harness/act.org
@@ -1,187 +0,0 @@
|
||||
#+TITLE: Stage 3: Act (act.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:act:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle act.lisp
|
||||
|
||||
* Overview
|
||||
The Act stage dispatches approved actions to registered actuators. After the Probabilistic engine proposes and the Deterministic engine verifies, Act executes the approved action via the appropriate actuator (:cli, :tool, :system, :telegram, :signal, etc.). The actuator registry is extensible — skills can register new actuators at runtime.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Actuator Configuration
|
||||
#+begin_src lisp
|
||||
(defvar *default-actuator* :cli
|
||||
"The actuator used when no explicit target is specified.")
|
||||
|
||||
(defvar *silent-actuators* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.")
|
||||
|
||||
(defun initialize-actuators ()
|
||||
"Register core actuators and load configuration."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
(when def
|
||||
(setf *default-actuator* (intern (string-upcase def) :keyword)))
|
||||
(when silent
|
||||
(setf *silent-actuators*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string silent :separator '(#\,))))))
|
||||
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :tool #'execute-tool-action)
|
||||
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((meta (getf action :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
#+end_src
|
||||
|
||||
** Action Dispatch (dispatch-action)
|
||||
#+begin_src lisp
|
||||
(defun dispatch-action (action context)
|
||||
"Route an approved action to its registered actuator."
|
||||
(let ((payload (proto-get action :payload)))
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from dispatch-action nil))
|
||||
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *default-actuator*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(harness-log "ACT ERROR: No actuator registered for '~s'" target))))))
|
||||
#+end_src
|
||||
|
||||
** System Actuator (execute-system-action)
|
||||
#+begin_src lisp
|
||||
(defun execute-system-action (action context)
|
||||
"Execute internal harness commands."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :action)))
|
||||
(case cmd
|
||||
(:eval
|
||||
(eval (read-from-string (getf payload :code))))
|
||||
(:message
|
||||
(harness-log "ACT [System]: ~a" (getf payload :text)))
|
||||
(t
|
||||
(harness-log "ACT ERROR [System]: Unknown command '~s'" cmd)))))
|
||||
#+end_src
|
||||
|
||||
** Tool Actuator (execute-tool-action)
|
||||
#+begin_src lisp
|
||||
(defun execute-tool-action (action context)
|
||||
"Execute a registered cognitive tool."
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
(when source
|
||||
(dispatch-action (list :TYPE :REQUEST :TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result)))
|
||||
context))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
|
||||
(error (c)
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
|
||||
#+end_src
|
||||
|
||||
** Tool Result Formatting (format-tool-result)
|
||||
#+begin_src lisp
|
||||
(defun format-tool-result (tool-name result)
|
||||
"Format a tool result for display."
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond
|
||||
((and (eq status :success) content) (format nil "~a" content))
|
||||
((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
#+end_src
|
||||
|
||||
** Act Gate (Stage 3)
|
||||
#+begin_src lisp
|
||||
(defun act-gate (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf feedback verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
(case type
|
||||
(:REQUEST (dispatch-action signal signal))
|
||||
(:LOG (dispatch-action signal signal))
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (dispatch-action approved signal)))
|
||||
(cond
|
||||
((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
((and result (not (member target *silent-actuators*)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))
|
||||
(when source (dispatch-action signal signal)))))
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/pipeline-act-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-pipeline-act-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :opencortex-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-act-gate-basic
|
||||
(clrhash opencortex::*skills-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (act-gate signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
@@ -1,9 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming protocol messages."
|
||||
(unless (listp msg) (error "Message must be a plist"))
|
||||
(let ((type (proto-get msg :type)))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
@@ -1,97 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (sanitize-protocol-message v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (sanitize-protocol-message msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(if (< count 6)
|
||||
:eof
|
||||
(let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
:error
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil))
|
||||
(handler-case (read-from-string msg-buffer)
|
||||
(error () :error)))))))))
|
||||
(error () :error))))
|
||||
|
||||
(defvar *server-socket* nil)
|
||||
|
||||
(defun handle-client-connection (socket)
|
||||
"Handles a single TUI/CLI client connection in a dedicated thread."
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
(cond
|
||||
((eq msg :eof) (return))
|
||||
((eq msg :error) (return))
|
||||
((eq (getf msg :type) :health-check)
|
||||
;; Handle health check request
|
||||
(let ((health-msg (list :type :health-response
|
||||
:status (or (and (boundp 'opencortex::*system-health*)
|
||||
(symbol-value 'opencortex::*system-health*))
|
||||
:unknown)
|
||||
:checked-p (or (and (boundp 'opencortex::*health-check-ran*)
|
||||
(symbol-value 'opencortex::*health-check-ran*))
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (inject-stimulus msg :stream stream))))))
|
||||
(error (c) (harness-log "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
(defun start-daemon (&key (port 9105))
|
||||
"Starts the network listener for TUI/CLI clients."
|
||||
(setf *server-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t))
|
||||
(harness-log "DAEMON: Listening on localhost:~a" port)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(let ((client-socket (usocket:socket-accept *server-socket*)))
|
||||
(when client-socket
|
||||
(bt:make-thread (lambda () (handle-client-connection client-socket))
|
||||
:name "opencortex-client-handler")))))
|
||||
:name "opencortex-server-listener"))
|
||||
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :ORG-AST))))
|
||||
@@ -1,186 +0,0 @@
|
||||
#+TITLE: Communication Protocol (communication.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:protocol:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle communication.lisp
|
||||
|
||||
* Overview
|
||||
The ~communication.lisp~ module defines the low-level transport and framing logic for OpenCortex stimuli.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Actuator Registry
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
#+end_src
|
||||
|
||||
** Message Framing
|
||||
#+begin_src lisp
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (sanitize-protocol-message v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (sanitize-protocol-message msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(if (< count 6)
|
||||
:eof
|
||||
(let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
:error
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil))
|
||||
(handler-case (read-from-string msg-buffer)
|
||||
(error () :error)))))))))
|
||||
(error () :error))))
|
||||
#+end_src
|
||||
|
||||
** Server Listener (start-daemon)
|
||||
#+begin_src lisp
|
||||
(defvar *server-socket* nil)
|
||||
|
||||
(defun handle-client-connection (socket)
|
||||
"Handles a single TUI/CLI client connection in a dedicated thread."
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
(cond
|
||||
((eq msg :eof) (return))
|
||||
((eq msg :error) (return))
|
||||
((eq (getf msg :type) :health-check)
|
||||
;; Handle health check request
|
||||
(let ((health-msg (list :type :health-response
|
||||
:status (or (and (boundp 'opencortex::*system-health*)
|
||||
(symbol-value 'opencortex::*system-health*))
|
||||
:unknown)
|
||||
:checked-p (or (and (boundp 'opencortex::*health-check-ran*)
|
||||
(symbol-value 'opencortex::*health-check-ran*))
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (inject-stimulus msg :stream stream))))))
|
||||
(error (c) (harness-log "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
(defun start-daemon (&key (port 9105))
|
||||
"Starts the network listener for TUI/CLI clients."
|
||||
(setf *server-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t))
|
||||
(harness-log "DAEMON: Listening on localhost:~a" port)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(let ((client-socket (usocket:socket-accept *server-socket*)))
|
||||
(when client-socket
|
||||
(bt:make-thread (lambda () (handle-client-connection client-socket))
|
||||
:name "opencortex-client-handler")))))
|
||||
:name "opencortex-server-listener"))
|
||||
#+end_src
|
||||
|
||||
** Handshake Logic
|
||||
#+begin_src lisp
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :ORG-AST))))
|
||||
#+end_src
|
||||
|
||||
** Structural Validation
|
||||
#+begin_src lisp :tangle communication-validator.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming protocol messages."
|
||||
(unless (listp msg) (error "Message must be a plist"))
|
||||
(let ((type (proto-get msg :type)))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
** Protocol Smoke Test (manual for REPL evaluation)
|
||||
The following script connects to a running daemon, sends "hi", and reads the response. Useful for verifying the daemon is alive and the framing protocol works end-to-end.
|
||||
|
||||
#+begin_src lisp :tangle no
|
||||
(defun test-daemon-protocol ()
|
||||
(handler-case
|
||||
(let* ((socket (usocket:socket-connect "127.0.0.1" 9105))
|
||||
(stream (usocket:socket-stream socket)))
|
||||
(format t "Connected.~%")
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(when (= count 6)
|
||||
(let* ((len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(format t "HELLO: ~a~%" msg-buf))))
|
||||
(let* ((msg '(:TYPE :EVENT :META (:SOURCE :tui) :PAYLOAD (:SENSOR :user-input :TEXT "hi")))
|
||||
(framed (frame-message msg)))
|
||||
(format stream "~a" framed)
|
||||
(finish-output stream)
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(when (= count 6)
|
||||
(let* ((len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(format t "Response: ~a~%" msg-buf)))))
|
||||
(usocket:socket-close socket))
|
||||
(error (c) (format t "Error: ~a~%" c))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/communication-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-communication-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :opencortex-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
#+end_src
|
||||
@@ -1,148 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun context-get-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
(defun context-list-all-skills ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "OC_DATA_DIR") (namestring (merge-pathnames ".local/share/opencortex/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "skills/" data-dir))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when is-semantically-relevant
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
|
||||
(defun context-resolve-path (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
path-string)))
|
||||
(if (and (stringp path) (search "$" path))
|
||||
(let ((result path))
|
||||
(ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path)
|
||||
(let ((var-val (uiop:getenv var-name)))
|
||||
(when var-val
|
||||
(setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val)))))
|
||||
result)
|
||||
path)))
|
||||
|
||||
(defun context-object-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :opencortex.skills.org-skill-bouncer)
|
||||
(symbol-value
|
||||
(find-symbol "BOUNCER-PRIVACY-TAGS"
|
||||
:opencortex.skills.org-skill-bouncer)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
|
||||
(defun context-object-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :opencortex.skills.org-skill-bouncer)
|
||||
(symbol-value
|
||||
(find-symbol "BOUNCER-PRIVACY-TAGS"
|
||||
:opencortex.skills.org-skill-bouncer)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM.
|
||||
Privacy-filtered objects (matching *privacy-filter-tags*) are excluded."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(all-projects (context-get-active-projects))
|
||||
(projects (remove-if #'context-object-privacy-filtered-p all-projects))
|
||||
(output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%")))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project :foveal-id foveal-id))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
@@ -1,229 +0,0 @@
|
||||
#+TITLE: Context API (context.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:context:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle context.lisp
|
||||
|
||||
* Overview
|
||||
The *Context API* (Peripheral Vision) provides the opencortex with the ability to selectively prune and present its memory to the LLM. It implements a **Foveal-Peripheral model**, where the current task is shown in high detail (foveal), while the broader Memex structure is shown as a skeletal outline (peripheral).
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Memory Query (context-query-store)
|
||||
#+begin_src lisp
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
** Active Projects (context-get-active-projects)
|
||||
#+begin_src lisp
|
||||
(defun context-get-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
#+end_src
|
||||
|
||||
** Completed Tasks (context-get-recent-completed-tasks)
|
||||
#+begin_src lisp
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
#+end_src
|
||||
|
||||
** Capability Discovery (context-list-all-skills)
|
||||
#+begin_src lisp
|
||||
(defun context-list-all-skills ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Inspection (context-get-skill-source)
|
||||
#+begin_src lisp
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "OC_DATA_DIR") (namestring (merge-pathnames ".local/share/opencortex/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "skills/" data-dir))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
#+end_src
|
||||
|
||||
** Harness Logs (context-get-system-logs)
|
||||
#+begin_src lisp
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
#+end_src
|
||||
|
||||
** AST to Org Rendering (context-render-to-org)
|
||||
#+begin_src lisp
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when is-semantically-relevant
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Path Resolution (context-resolve-path)
|
||||
#+begin_src lisp
|
||||
(defun context-resolve-path (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
path-string)))
|
||||
(if (and (stringp path) (search "$" path))
|
||||
(let ((result path))
|
||||
(ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path)
|
||||
(let ((var-val (uiop:getenv var-name)))
|
||||
(when var-val
|
||||
(setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val)))))
|
||||
result)
|
||||
path)))
|
||||
#+end_src
|
||||
|
||||
** Privacy filter for context assembly
|
||||
Checks if an org-object has tags matching ~*privacy-filter-tags*~. Objects with matching tags are excluded from the LLM context window.
|
||||
#+begin_src lisp
|
||||
(defun context-object-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :opencortex.skills.org-skill-bouncer)
|
||||
(symbol-value
|
||||
(find-symbol "BOUNCER-PRIVACY-TAGS"
|
||||
:opencortex.skills.org-skill-bouncer)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
#+end_src
|
||||
|
||||
** Global Awareness (context-assemble-global-awareness)
|
||||
#+begin_src lisp
|
||||
(defun context-object-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :opencortex.skills.org-skill-bouncer)
|
||||
(symbol-value
|
||||
(find-symbol "BOUNCER-PRIVACY-TAGS"
|
||||
:opencortex.skills.org-skill-bouncer)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM.
|
||||
Privacy-filtered objects (matching *privacy-filter-tags*) are excluded."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(all-projects (context-get-active-projects))
|
||||
(projects (remove-if #'context-object-privacy-filtered-p all-projects))
|
||||
(output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%")))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project :foveal-id foveal-id))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-peripheral-vision-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:vision-suite))
|
||||
(in-package :opencortex-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
(clrhash opencortex::*memory*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-assemble-global-awareness (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
(clrhash opencortex::*memory*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-assemble-global-awareness)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
#+end_src
|
||||
@@ -1,81 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
(defun doctor-check-dependencies ()
|
||||
"Verifies that required external binaries are available in the PATH via a shell probe."
|
||||
(let ((all-ok t))
|
||||
(harness-log "DOCTOR: Checking system dependencies...")
|
||||
(dolist (dep *doctor-required-binaries*)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
:output :string :ignore-error-status t))))
|
||||
(if (and path (> (length path) 0))
|
||||
(harness-log " [OK] Found ~a" dep)
|
||||
(progn
|
||||
(harness-log " [FAIL] Missing binary: ~a" dep)
|
||||
(setf all-ok nil)))))
|
||||
all-ok))
|
||||
|
||||
(defun doctor-check-env ()
|
||||
"Validates XDG directories and environment configuration against the POSIX standard."
|
||||
(harness-log "DOCTOR: Checking XDG environment...")
|
||||
(let ((all-ok t)
|
||||
(config-dir (uiop:getenv "OC_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "OC_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "OC_STATE_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR")))
|
||||
|
||||
(flet ((check-dir (name path critical)
|
||||
(if (and path (> (length path) 0))
|
||||
(if (uiop:directory-exists-p path)
|
||||
(harness-log " [OK] ~a: ~a" name path)
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a directory missing: ~a" name path)
|
||||
(when critical (setf all-ok nil))))
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a variable not set." name)
|
||||
(when critical (setf all-ok nil))))))
|
||||
|
||||
(check-dir "Config (OC_CONFIG_DIR)" config-dir t)
|
||||
(check-dir "Data (OC_DATA_DIR)" data-dir t)
|
||||
(check-dir "State (OC_STATE_DIR)" state-dir t)
|
||||
(check-dir "Memex (MEMEX_DIR)" memex-dir t))
|
||||
all-ok))
|
||||
|
||||
(defun doctor-check-llm ()
|
||||
"Tests connectivity to primary LLM providers. Non-critical fallback allowed."
|
||||
(harness-log "DOCTOR: Checking LLM connectivity...")
|
||||
(let ((openrouter-key (uiop:getenv "OPENROUTER_API_KEY")))
|
||||
(if (and openrouter-key (> (length openrouter-key) 0))
|
||||
(progn
|
||||
(harness-log " [OK] OpenRouter API Key detected.")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " [WARN] No OpenRouter API Key. Falling back to local inference only.")
|
||||
t))))
|
||||
|
||||
(defun doctor-run-all ()
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
(harness-log "==================================================")
|
||||
(harness-log " OPENCORTEX DOCTOR: Commencing Health Check")
|
||||
(harness-log "==================================================")
|
||||
(let ((dep-ok (doctor-check-dependencies))
|
||||
(env-ok (doctor-check-env))
|
||||
(llm-ok (doctor-check-llm)))
|
||||
(declare (ignore llm-ok))
|
||||
(harness-log "==================================================")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
(harness-log " ✓ SYSTEM HEALTHY: Ready for ignition.")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " ✗ SYSTEM UNHEALTHY: Fix the errors above.")
|
||||
nil))))
|
||||
|
||||
(defun doctor-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
(if (doctor-run-all)
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
@@ -1,163 +0,0 @@
|
||||
#+PROPERTY: header-args:lisp :tangle doctor.lisp
|
||||
#+TITLE: System Diagnostic Doctor (doctor.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:setup:diagnostic:
|
||||
#+STARTUP: content
|
||||
|
||||
* Overview
|
||||
The *System Doctor* is the primary diagnostic utility for the OpenCortex. Its purpose is to transform opaque startup failures into actionable engineering reports.
|
||||
|
||||
By centralizing environment validation, we ensure that the "Brain" never attempts to boot in a compromised or incomplete state.
|
||||
|
||||
* Phase A: Demand (Thinking)
|
||||
** The XDG Standard Rationale
|
||||
To ensure OpenCortex behaves as a first-class POSIX citizen, we adopt the **XDG Base Directory Specification**. This separates the system into four logical layers:
|
||||
|
||||
1. **Configuration (`~/.config/opencortex`)**: User-editable settings and secrets.
|
||||
2. **Data (`~/.local/share/opencortex`)**: Tangled Lisp engine artifacts (immutable by user).
|
||||
3. **State (`~/.local/state/opencortex`)**: Dynamic persistence like brain snapshots.
|
||||
4. **Bin (`~/.local/bin`)**: The CLI shim for global invocation.
|
||||
|
||||
** The Detection Invariant: Shell Probing
|
||||
Common Lisp's `getenv` is strictly typed in SBCL. The Doctor must ensure that missing variables are handled as logic failures, not type crashes. Furthermore, binary detection must use a shell probe (`command -v` or `which`) to account for varying `$PATH` inheritance between interactive and headless sessions.
|
||||
|
||||
* Phase B: Protocol (Success Criteria)
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
|
||||
(defpackage :opencortex-doctor-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:doctor-suite))
|
||||
|
||||
(in-package :opencortex-doctor-tests)
|
||||
|
||||
(def-suite doctor-suite :description "Verification of the System Doctor diagnostic logic")
|
||||
(in-suite doctor-suite)
|
||||
#+end_src
|
||||
|
||||
** Dependency Tests
|
||||
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
|
||||
(test test-dependency-check-fail
|
||||
"Verify that missing binaries are correctly identified as failures."
|
||||
(let ((opencortex::*doctor-required-binaries* '("non-existent-binary-123")))
|
||||
(is (null (opencortex:doctor-check-dependencies)))))
|
||||
#+end_src
|
||||
|
||||
** Environment Tests
|
||||
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
|
||||
(test test-env-validation-fail
|
||||
"Verify that an invalid MEMEX_DIR triggers a critical failure."
|
||||
(let ((old-m (uiop:getenv "MEMEX_DIR"))
|
||||
(old-d (uiop:getenv "OC_DATA_DIR")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "MEMEX_DIR") "/non/existent/path/999")
|
||||
(is (null (opencortex:doctor-check-env))))
|
||||
(setf (uiop:getenv "MEMEX_DIR") (or old-m ""))
|
||||
(setf (uiop:getenv "OC_DATA_DIR") (or old-d "")))))
|
||||
#+end_src
|
||||
|
||||
* Phase C: Implementation (Build)
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Global Configuration
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
#+end_src
|
||||
|
||||
** Dependency Verification
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-dependencies ()
|
||||
"Verifies that required external binaries are available in the PATH via a shell probe."
|
||||
(let ((all-ok t))
|
||||
(harness-log "DOCTOR: Checking system dependencies...")
|
||||
(dolist (dep *doctor-required-binaries*)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
:output :string :ignore-error-status t))))
|
||||
(if (and path (> (length path) 0))
|
||||
(harness-log " [OK] Found ~a" dep)
|
||||
(progn
|
||||
(harness-log " [FAIL] Missing binary: ~a" dep)
|
||||
(setf all-ok nil)))))
|
||||
all-ok))
|
||||
#+end_src
|
||||
|
||||
** Environment & XDG Validation
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-env ()
|
||||
"Validates XDG directories and environment configuration against the POSIX standard."
|
||||
(harness-log "DOCTOR: Checking XDG environment...")
|
||||
(let ((all-ok t)
|
||||
(config-dir (uiop:getenv "OC_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "OC_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "OC_STATE_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR")))
|
||||
|
||||
(flet ((check-dir (name path critical)
|
||||
(if (and path (> (length path) 0))
|
||||
(if (uiop:directory-exists-p path)
|
||||
(harness-log " [OK] ~a: ~a" name path)
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a directory missing: ~a" name path)
|
||||
(when critical (setf all-ok nil))))
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a variable not set." name)
|
||||
(when critical (setf all-ok nil))))))
|
||||
|
||||
(check-dir "Config (OC_CONFIG_DIR)" config-dir t)
|
||||
(check-dir "Data (OC_DATA_DIR)" data-dir t)
|
||||
(check-dir "State (OC_STATE_DIR)" state-dir t)
|
||||
(check-dir "Memex (MEMEX_DIR)" memex-dir t))
|
||||
all-ok))
|
||||
#+end_src
|
||||
|
||||
** LLM Connectivity
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-llm ()
|
||||
"Tests connectivity to primary LLM providers. Non-critical fallback allowed."
|
||||
(harness-log "DOCTOR: Checking LLM connectivity...")
|
||||
(let ((openrouter-key (uiop:getenv "OPENROUTER_API_KEY")))
|
||||
(if (and openrouter-key (> (length openrouter-key) 0))
|
||||
(progn
|
||||
(harness-log " [OK] OpenRouter API Key detected.")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " [WARN] No OpenRouter API Key. Falling back to local inference only.")
|
||||
t))))
|
||||
#+end_src
|
||||
|
||||
** Orchestration
|
||||
#+begin_src lisp
|
||||
(defun doctor-run-all ()
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
(harness-log "==================================================")
|
||||
(harness-log " OPENCORTEX DOCTOR: Commencing Health Check")
|
||||
(harness-log "==================================================")
|
||||
(let ((dep-ok (doctor-check-dependencies))
|
||||
(env-ok (doctor-check-env))
|
||||
(llm-ok (doctor-check-llm)))
|
||||
(declare (ignore llm-ok))
|
||||
(harness-log "==================================================")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
(harness-log " ✓ SYSTEM HEALTHY: Ready for ignition.")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " ✗ SYSTEM UNHEALTHY: Fix the errors above.")
|
||||
nil))))
|
||||
#+end_src
|
||||
|
||||
** CLI Entry Point
|
||||
#+begin_src lisp
|
||||
(defun doctor-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
(if (doctor-run-all)
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
#+end_src
|
||||
@@ -1,136 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.")
|
||||
|
||||
(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.")
|
||||
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread.")
|
||||
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10)
|
||||
(harness-log "METABOLISM ERROR: Max recursion depth reached.")
|
||||
(return nil))
|
||||
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "METABOLISM: Interrupted by shutdown signal.")
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(harness-log "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
|
||||
(defvar *auto-save-interval* 300)
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
(defun start-heartbeat ()
|
||||
"Starts the background heartbeat thread."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*)))
|
||||
(setf *auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(inject-stimulus
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "opencortex-heartbeat"))))
|
||||
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
|
||||
(defvar *system-health* :unknown
|
||||
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
|
||||
|
||||
(defvar *health-check-ran* nil
|
||||
"Flag indicating if initial health check has completed.")
|
||||
|
||||
(defun run-startup-health-check ()
|
||||
"Runs the doctor diagnostics on startup. Returns health status."
|
||||
(format t "~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " DOCTOR: Running Startup Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'doctor-run-all)
|
||||
(let ((result (doctor-run-all)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
(setf *system-health* :healthy)
|
||||
(format t "DAEMON: Health check passed. Starting services.~%"))
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'opencortex doctor --fix' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DOCTOR ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
|
||||
(defun main ()
|
||||
"Entry point for OpenCortex. Initializes the system and enters idle loop."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".config/opencortex/.env" (uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
(run-startup-health-check)
|
||||
|
||||
(start-heartbeat)
|
||||
(start-daemon)
|
||||
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
|
||||
(loop
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
198
harness/loop.org
198
harness/loop.org
@@ -1,198 +0,0 @@
|
||||
#+TITLE: The Metabolic Loop (loop.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:loop:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle loop.lisp
|
||||
|
||||
* Overview
|
||||
The Metabolic Loop is the fundamental rhythm of OpenCortex: the continuous processing of signals from perception through cognition to action.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Global Variables (Thread-Safe)
|
||||
#+begin_src lisp
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.")
|
||||
|
||||
(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.")
|
||||
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread.")
|
||||
#+end_src
|
||||
|
||||
** Core Engine (process-signal)
|
||||
#+begin_src lisp
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10)
|
||||
(harness-log "METABOLISM ERROR: Max recursion depth reached.")
|
||||
(return nil))
|
||||
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "METABOLISM: Interrupted by shutdown signal.")
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(harness-log "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
#+end_src
|
||||
|
||||
** Heartbeat Mechanism
|
||||
#+begin_src lisp
|
||||
(defvar *auto-save-interval* 300)
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
(defun start-heartbeat ()
|
||||
"Starts the background heartbeat thread."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*)))
|
||||
(setf *auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(inject-stimulus
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "opencortex-heartbeat"))))
|
||||
#+end_src
|
||||
|
||||
** Shutdown Flag
|
||||
#+begin_src lisp
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
#+end_src
|
||||
|
||||
** Health Status
|
||||
#+begin_src lisp
|
||||
(defvar *system-health* :unknown
|
||||
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
|
||||
|
||||
(defvar *health-check-ran* nil
|
||||
"Flag indicating if initial health check has completed.")
|
||||
#+end_src
|
||||
|
||||
** Proactive Doctor
|
||||
#+begin_src lisp
|
||||
(defun run-startup-health-check ()
|
||||
"Runs the doctor diagnostics on startup. Returns health status."
|
||||
(format t "~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " DOCTOR: Running Startup Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'doctor-run-all)
|
||||
(let ((result (doctor-run-all :auto-install nil)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
(setf *system-health* :healthy)
|
||||
(format t "DAEMON: Health check passed. Starting services.~%"))
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'opencortex doctor --fix' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DOCTOR ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
#+end_src
|
||||
|
||||
** Main Entry Point (main)
|
||||
#+begin_src lisp
|
||||
(defun main ()
|
||||
"Entry point for OpenCortex. Initializes the system and enters idle loop."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".config/opencortex/.env" (uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
(run-startup-health-check)
|
||||
|
||||
(start-heartbeat)
|
||||
(start-daemon)
|
||||
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
|
||||
(loop
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/immune-system-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-immune-system-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :opencortex-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Verify that a crash in think/decide triggers a :loop-error stimulus."
|
||||
(clrhash opencortex::*skills-registry*)
|
||||
(opencortex:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(opencortex:process-signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (opencortex:context-get-system-logs 20)))
|
||||
(is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))
|
||||
#+end_src
|
||||
@@ -1,64 +0,0 @@
|
||||
#+TITLE: System Manifest (manifest.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:manifest:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle ../opencortex.asd
|
||||
|
||||
* Overview
|
||||
The *System Manifest* defines the structural components of the OpenCortex.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Main System
|
||||
#+begin_src lisp
|
||||
(defsystem :opencortex
|
||||
:name "opencortex"
|
||||
:author "Amr Gharbeia"
|
||||
:version "0.2.0"
|
||||
:license "AGPLv3"
|
||||
:description "The Probabilistic-Deterministic Lisp Machine"
|
||||
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
|
||||
:serial t
|
||||
:components ((:file "harness/package")
|
||||
(:file "harness/skills")
|
||||
(:file "harness/communication")
|
||||
(:file "harness/communication-validator")
|
||||
(:file "harness/memory")
|
||||
(:file "harness/context")
|
||||
(:file "harness/perceive")
|
||||
(:file "harness/reason")
|
||||
(:file "harness/act")
|
||||
(:file "harness/loop")))
|
||||
#+end_src
|
||||
|
||||
** Test System
|
||||
#+begin_src lisp
|
||||
(defsystem :opencortex/tests
|
||||
:depends-on (:opencortex :fiveam)
|
||||
:components ((:file "tests/pipeline-act-tests")
|
||||
(:file "tests/boot-sequence-tests")
|
||||
(:file "tests/immune-system-tests")
|
||||
(:file "tests/memory-tests")
|
||||
(:file "tests/pipeline-perceive-tests")
|
||||
(:file "tests/pipeline-reason-tests")
|
||||
(:file "tests/peripheral-vision-tests")
|
||||
(:file "tests/utils-org-tests")
|
||||
(:file "tests/engineering-standards-tests")
|
||||
(:file "tests/utils-lisp-tests")
|
||||
(:file "tests/literate-programming-tests")
|
||||
(:file "tests/self-edit-tests")
|
||||
(:file "tests/tool-permissions-tests")
|
||||
(:file "tests/diagnostics-tests")
|
||||
(:file "tests/config-manager-tests")
|
||||
(:file "tests/gateway-manager-tests")
|
||||
(:file "tests/tui-tests")
|
||||
(:file "tests/llm-gateway-tests")))
|
||||
#+end_src
|
||||
|
||||
** TUI System
|
||||
#+begin_src lisp
|
||||
(defsystem :opencortex/tui
|
||||
:depends-on (:opencortex :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "harness/tui-client")))
|
||||
#+end_src
|
||||
|
||||
@@ -1,120 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
|
||||
(defun lookup-object (id)
|
||||
(gethash id *memory*))
|
||||
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
|
||||
(defmethod make-load-form ((obj org-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
|
||||
(defun deep-copy-org-object (obj)
|
||||
(make-org-object :id (org-object-id obj)
|
||||
:type (org-object-type obj)
|
||||
:attributes (copy-list (org-object-attributes obj))
|
||||
:content (org-object-content obj)
|
||||
:vector (org-object-vector obj)
|
||||
:parent-id (org-object-parent-id obj)
|
||||
:children (copy-list (org-object-children obj))
|
||||
:version (org-object-version obj)
|
||||
:last-sync (org-object-last-sync obj)
|
||||
:hash (org-object-hash obj)))
|
||||
|
||||
(defun compute-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) ""))))
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory*)))
|
||||
(when child-obj (push (org-object-hash child-obj) child-hashes))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *history-store*))
|
||||
(obj (or existing-obj
|
||||
(make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj (setf (gethash hash *history-store*) obj))
|
||||
(setf (gethash id *memory*) obj)
|
||||
id)))
|
||||
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-hash-table (hash-table)
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
|
||||
(defun snapshot-memory ()
|
||||
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory*))))
|
||||
(maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-org-object v))) *memory*)
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
(when (> (length *object-store-snapshots*) 20) (setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
||||
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
||||
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
(defvar *memory-snapshot-path* nil)
|
||||
|
||||
(defun ensure-memory-snapshot-path ()
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
||||
|
||||
(defun save-memory-to-disk ()
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(let ((memory-alist nil) (history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(harness-log "MEMORY - Saved to ~a" path)))
|
||||
|
||||
(defun load-memory-from-disk ()
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (read stream nil)))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
|
||||
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist) (setf (gethash (car kv) *memory*) (cdr kv)))
|
||||
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist) (setf (gethash (car kv) *history-store*) (cdr kv)))
|
||||
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
|
||||
(error (c) (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
|
||||
t)
|
||||
@@ -1,248 +0,0 @@
|
||||
#+TITLE: The System Memory (memory.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:memory:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle memory.lisp
|
||||
|
||||
* Overview
|
||||
The Memory module is the agent's live cognitive state — a set of Merkle-tree-versioned ~org-object~ instances stored in hash tables. Every perception, action, and decision is recorded here.
|
||||
|
||||
Key structures:
|
||||
- ~*memory*~ — the primary object store, keyed by ID
|
||||
- ~*history-store*~ — immutable archive of all past object versions, keyed by SHA-256 hash
|
||||
- ~org-object~ — the universal data unit (id, type, attributes, content, vector embedding, parent, children, merkle hash)
|
||||
- ~ingest-ast~ — converts an Org-mode AST into ~org-object~ instances, computing Merkle hashes for integrity
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** The Object Repository
|
||||
#+begin_src lisp
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
#+end_src
|
||||
|
||||
** Object Lookup (lookup-object)
|
||||
Retrieve a single object by its ID from the active memory store.
|
||||
#+begin_src lisp
|
||||
(defun lookup-object (id)
|
||||
"Retrieves an org-object by ID from *memory*."
|
||||
(gethash id *memory*))
|
||||
#+end_src
|
||||
|
||||
** Object search (list-objects-with-attribute)
|
||||
Scan the entire memory store for objects whose attributes match a given key-value pair.
|
||||
#+begin_src lisp
|
||||
(defun list-objects-with-attribute (attr value)
|
||||
"Returns all org-objects whose :ATTRIBUTES plist has ATTR = VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (equal (getf (org-object-attributes obj) attr) value)
|
||||
(push obj results)))
|
||||
*memory*)
|
||||
(nreverse results)))
|
||||
#+end_src
|
||||
|
||||
** ID generation (org-id-new)
|
||||
Generate a unique identifier string for a new Org node. Uses the universal time encoded in base-36 for compactness.
|
||||
#+begin_src lisp
|
||||
(defun org-id-new ()
|
||||
"Generates a timestamp-based unique ID."
|
||||
(format nil "id-~36r" (get-universal-time)))
|
||||
#+end_src
|
||||
|
||||
** The Data Structure (org-object)
|
||||
The universal data unit. Every stored entity is an ~org-object~ with an ID, type, attribute plist, content string, optional vector embedding, parent/child pointers, version timestamp, and Merkle hash.
|
||||
#+begin_src lisp
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
#+end_src
|
||||
|
||||
** Serialization support
|
||||
Required by the Lisp runtime for saving/loading objects across image restarts.
|
||||
#+begin_src lisp
|
||||
(defmethod make-load-form ((obj org-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
#+end_src
|
||||
|
||||
** Deep copy
|
||||
Creates an independent copy of an ~org-object~. Used by the snapshot system to capture consistent memory state.
|
||||
#+begin_src lisp
|
||||
(defun deep-copy-org-object (obj)
|
||||
"Creates a full copy of an org-object, including a fresh list copy of attributes and children."
|
||||
(make-org-object :id (org-object-id obj)
|
||||
:type (org-object-type obj)
|
||||
:attributes (copy-list (org-object-attributes obj))
|
||||
:content (org-object-content obj)
|
||||
:vector (org-object-vector obj)
|
||||
:parent-id (org-object-parent-id obj)
|
||||
:children (copy-list (org-object-children obj))
|
||||
:version (org-object-version obj)
|
||||
:last-sync (org-object-last-sync obj)
|
||||
:hash (org-object-hash obj)))
|
||||
#+end_src
|
||||
|
||||
** Merkle Tree Integrity
|
||||
#+begin_src lisp
|
||||
(defun compute-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
#+end_src
|
||||
|
||||
** Ingest (ingest-ast)
|
||||
#+begin_src lisp
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) ""))))
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory*)))
|
||||
(when child-obj (push (org-object-hash child-obj) child-hashes))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *history-store*))
|
||||
(obj (or existing-obj
|
||||
(make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj (setf (gethash hash *history-store*) obj))
|
||||
(setf (gethash id *memory*) obj)
|
||||
id)))
|
||||
#+end_src
|
||||
|
||||
** Snapshot history (~*object-store-snapshots*~)
|
||||
A stack of CoW (copy-on-write) memory snapshots for rollback. Up to 20 snapshots are retained.
|
||||
#+begin_src lisp
|
||||
(defvar *object-store-snapshots* nil)
|
||||
#+end_src
|
||||
|
||||
** Hash table copy utility
|
||||
Used by the rollback system to restore saved memory state.
|
||||
#+begin_src lisp
|
||||
(defun copy-hash-table (hash-table)
|
||||
"Creates an independent copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
#+end_src
|
||||
|
||||
** Memory snapshot (snapshot-memory)
|
||||
Captures a point-in-time copy of ~*memory*~. Each object is deep-copied so the snapshot is independent of ongoing mutations.
|
||||
#+begin_src lisp
|
||||
(defun snapshot-memory ()
|
||||
"Creates a CoW snapshot of *memory* for rollback recovery."
|
||||
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory*))))
|
||||
(maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-org-object v))) *memory*)
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
(when (> (length *object-store-snapshots*) 20)
|
||||
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
||||
#+end_src
|
||||
|
||||
** Memory rollback (rollback-memory)
|
||||
Restores ~*memory*~ to a previous snapshot. By default restores the most recent snapshot (index 0).
|
||||
#+begin_src lisp
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores *memory* from a snapshot. INDEX 0 = most recent."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
||||
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
#+end_src
|
||||
|
||||
** Persistence — snapshot path (~*memory-snapshot-path*~)
|
||||
Configurable path for serialized memory state. Falls back to ~memory.snap~ in the home directory.
|
||||
#+begin_src lisp
|
||||
(defvar *memory-snapshot-path* nil)
|
||||
|
||||
(defun ensure-memory-snapshot-path ()
|
||||
"Returns the path to the memory snapshot file, resolving env or default."
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
||||
#+end_src
|
||||
|
||||
** Save to disk (save-memory-to-disk)
|
||||
Serialises ~*memory*~ and ~*history-store*~ to a Lisp-readable file.
|
||||
#+begin_src lisp
|
||||
(defun save-memory-to-disk ()
|
||||
"Writes the entire memory and history store to disk as a plist."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(let ((memory-alist nil) (history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(harness-log "MEMORY - Saved to ~a" path)))
|
||||
#+end_src
|
||||
|
||||
** Load from disk (load-memory-from-disk)
|
||||
Restores memory state from a previously saved snapshot file.
|
||||
#+begin_src lisp
|
||||
(defun load-memory-from-disk ()
|
||||
"Reads memory state from disk and restores *memory* and *history-store*."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (read stream nil)))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
|
||||
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist) (setf (gethash (car kv) *memory*) (cdr kv)))
|
||||
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist) (setf (gethash (car kv) *history-store*) (cdr kv)))
|
||||
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
|
||||
(error (c) (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
|
||||
t)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/memory-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-memory-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :opencortex-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash opencortex::*memory*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (org-object-hash (lookup-object id1))))
|
||||
(clrhash opencortex::*memory*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (org-object-hash (lookup-object id2)))))))))
|
||||
#+end_src
|
||||
@@ -1,268 +0,0 @@
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; --- communication protocol ---
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
|
||||
;; --- Daemon Lifecycle ---
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:harness-log
|
||||
#:main
|
||||
|
||||
;; --- Diagnostic Doctor ---
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
|
||||
;; --- Setup Wizard ---
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:run-setup-wizard
|
||||
|
||||
;; --- Gateway Manager Skill ---
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
|
||||
;; --- Memory (CLOSOS) ---
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
|
||||
;; --- Context API (Peripheral Vision) ---
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:harness-track-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
|
||||
;; --- Reactive Signal Pipeline ---
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:perceive-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
|
||||
;; --- Tool Registry ---
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tools*
|
||||
|
||||
;; --- Engineering Standards Skill ---
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
|
||||
;; --- Literate Programming Skill ---
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
|
||||
;; --- Utils Org Skill ---
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
|
||||
;; --- Utils Lisp Skill ---
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
|
||||
;; --- Config Manager & Diagnostics Skill ---
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
|
||||
;; --- Tool Permissions Skill ---
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
|
||||
;; --- Emacs Client Registry ---
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
|
||||
;; --- Probabilistic Engine ---
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*provider-cascade*
|
||||
|
||||
;; --- Security Vault ---
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
|
||||
;; --- Deterministic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:deterministic-verify
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a new cognitive tool into the global registry. Parameters must be a list of property lists."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Generates a prompt string describing all available cognitive tools."
|
||||
(let ((descriptions nil))
|
||||
(maphash (lambda (k tool)
|
||||
(declare (ignore k))
|
||||
(push (format nil "- ~a: ~a~% Parameters: ~a~%"
|
||||
(cognitive-tool-name tool)
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool))
|
||||
descriptions))
|
||||
*cognitive-tools*)
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
|
||||
;; --- Debugger Hook ---
|
||||
(setf *debugger-hook* (lambda (condition hook)
|
||||
"Friendly error handler - shows diagnostic message instead of raw debugger."
|
||||
(declare (ignore hook))
|
||||
(format t "~%")
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: opencortex doctor~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
@@ -1,288 +0,0 @@
|
||||
#+TITLE: System Interface (package.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:interface:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle package.lisp
|
||||
|
||||
* Overview
|
||||
~package.lisp~ defines two things: the public API of the ~opencortex~ package (the export list, above), and the implementation of low-level utility functions and global state that don't belong in a specific pipeline stage or skill.
|
||||
|
||||
The export list is the contract between the harness and all skills. Every function exported here is accessible to every skill via ~use-package~. Adding a symbol here is an API commitment; removing one is a breaking change.
|
||||
|
||||
The implementation section includes:
|
||||
- ~proto-get~ — robust plist accessor used everywhere
|
||||
- Logging state (~*system-logs*~, ~*logs-lock*~)
|
||||
- Skill registry (~*skills-registry*~, ~defskill~)
|
||||
- Cognitive tool registry (~*cognitive-tools*~, ~def-cognitive-tool~)
|
||||
- Configuration variables (~*privacy-filter-tags*~, ~*secret-protected-paths*~, ~*secret-exposure-patterns*~)
|
||||
- Debugger hook
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Definition and Export List
|
||||
The package definition. All public symbols are exported here.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:harness-log
|
||||
#:main
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:run-setup-wizard
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:harness-track-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tools*
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:list-objects-with-attribute
|
||||
#:deterministic-verify
|
||||
#:find-headline-missing-id))
|
||||
#+end_src
|
||||
|
||||
** Package Implementation
|
||||
The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills.
|
||||
|
||||
*** Robust plist access (proto-get)
|
||||
Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robust plist accessor — checks both :KEY and :key variants."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
*** Logging state
|
||||
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
#+end_src
|
||||
|
||||
*** Skill registry
|
||||
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
#+end_src
|
||||
|
||||
*** Skill telemetry
|
||||
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
#+end_src
|
||||
|
||||
*** Cognitive tool registry
|
||||
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~generate-tool-belt-prompt~ serialises the registry into the LLM's system prompt.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Serialises all registered tools into a prompt string for the LLM."
|
||||
(let ((descriptions nil))
|
||||
(maphash (lambda (k tool)
|
||||
(declare (ignore k))
|
||||
(push (format nil "- ~a: ~a~% Parameters: ~a~%"
|
||||
(cognitive-tool-name tool)
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool))
|
||||
descriptions))
|
||||
*cognitive-tools*)
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
#+end_src
|
||||
|
||||
*** Centralized logging (harness-log)
|
||||
Thread-safe logging function that writes to both the ring buffer (for LLM context) and stdout (for the user). Bounded by ~*max-log-history*~.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized, thread-safe logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
#+end_src
|
||||
|
||||
*** Debugger hook
|
||||
Friendly error handler that replaces the raw SBCL debugger with a diagnostic message. This prevents the agent from entering the debugger on unhandled conditions.
|
||||
#+begin_src lisp :tangle package.lisp
|
||||
(setf *debugger-hook* (lambda (condition hook)
|
||||
"Friendly error handler - shows diagnostic message instead of raw debugger."
|
||||
(declare (ignore hook))
|
||||
(format t "~%")
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: opencortex doctor~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
#+end_src
|
||||
@@ -1,72 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *interrupt-flag* nil)
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
(defvar *foveal-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p)
|
||||
(member sensor *async-sensors*))))
|
||||
|
||||
(unless meta
|
||||
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
|
||||
(when stream
|
||||
(setf (getf meta :reply-stream) stream))
|
||||
|
||||
(setf (getf raw-message :meta) meta)
|
||||
(setf (getf raw-message :depth) depth)
|
||||
|
||||
(if async-p
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case (process-signal raw-message)
|
||||
(skip-event () nil)))
|
||||
:name "opencortex-async-task")
|
||||
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(harness-log "SYSTEM ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event ()
|
||||
(harness-log "SYSTEM RECOVERY: Stimulus dropped."))))))
|
||||
|
||||
(defun perceive-gate (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
|
||||
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *foveal-focus-id* (getf element :id))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(setf *interrupt-flag* t))))
|
||||
((eq type :RESPONSE)
|
||||
(harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *foveal-focus-id*)
|
||||
signal))
|
||||
@@ -1,126 +0,0 @@
|
||||
#+TITLE: Stage 1: Perceive (perceive.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:perceive:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle perceive.lisp
|
||||
|
||||
* Overview
|
||||
The Perceive stage is the "sensory cortex" of OpenCortex. Its job is to take raw stimuli from the outside world and transform them into standardized Signals that the rest of the pipeline can process.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Interrupt Handling
|
||||
#+begin_src lisp
|
||||
(defvar *interrupt-flag* nil)
|
||||
#+end_src
|
||||
|
||||
** Sensor Configuration
|
||||
#+begin_src lisp
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
(defvar *foveal-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
#+end_src
|
||||
|
||||
** Stimulus Injection (inject-stimulus)
|
||||
#+begin_src lisp
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p)
|
||||
(member sensor *async-sensors*))))
|
||||
|
||||
(unless meta
|
||||
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
|
||||
(when stream
|
||||
(setf (getf meta :reply-stream) stream))
|
||||
|
||||
(setf (getf raw-message :meta) meta)
|
||||
(setf (getf raw-message :depth) depth)
|
||||
|
||||
(if async-p
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case (process-signal raw-message)
|
||||
(skip-event () nil)))
|
||||
:name "opencortex-async-task")
|
||||
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(harness-log "SYSTEM ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event ()
|
||||
(harness-log "SYSTEM RECOVERY: Stimulus dropped."))))))
|
||||
#+end_src
|
||||
|
||||
** Perceive Gate (perceive-gate)
|
||||
#+begin_src lisp
|
||||
(defun perceive-gate (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
|
||||
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *foveal-focus-id* (getf element :id))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(setf *interrupt-flag* t))))
|
||||
((eq type :RESPONSE)
|
||||
(harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *foveal-focus-id*)
|
||||
signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp :tangle ../tests/pipeline-perceive-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :opencortex-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-perceive-gate
|
||||
(clrhash opencortex::*memory*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (perceive-gate signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" opencortex::*memory*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
#+end_src
|
||||
@@ -1,132 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *provider-cascade* nil)
|
||||
|
||||
(defvar *model-selector-fn* nil)
|
||||
|
||||
(defvar *consensus-enabled-p* nil)
|
||||
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
|
||||
(defun probabilistic-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(harness-log "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector-fn*
|
||||
(funcall *model-selector-fn* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(harness-log "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
|
||||
(defun strip-markdown (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
|
||||
(defun normalize-plist-keywords (plist)
|
||||
(when (listp plist)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
|
||||
(defun think (context)
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness))
|
||||
(system-logs (context-get-system-logs))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
||||
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
||||
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(reflection-feedback (if rejection-trace
|
||||
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
||||
""))
|
||||
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs)))
|
||||
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (strip-markdown thought)))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(normalize-plist-keywords parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
||||
|
||||
(defun deterministic-verify (proposed-action context)
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
||||
(harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from deterministic-verify next-action))
|
||||
(when next-action (setf current-action next-action))))))
|
||||
current-action))
|
||||
|
||||
(defun reason-gate (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
||||
(return-from reason-gate signal))
|
||||
(let ((retries 3)
|
||||
(current-signal (copy-tree signal))
|
||||
(last-rejection nil))
|
||||
(loop
|
||||
(when (<= retries 0)
|
||||
(setf (getf signal :approved-action) last-rejection)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (deterministic-verify candidate current-signal)))
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
@@ -1,212 +0,0 @@
|
||||
#+TITLE: Stage 2: Reason (reason.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:reason:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle reason.lisp
|
||||
|
||||
* Overview
|
||||
The Reason stage implements the core Innovation of OpenCortex: the separation of probabilistic reasoning (neural/LLM) from deterministic verification (logic/safety).
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Probabilistic Engine state
|
||||
~*probabilistic-backends*~ is the hash table mapping provider keywords to backend functions. ~*provider-cascade*~ is the ordered list of providers to try. ~*model-selector-fn*~ is an optional function that selects a model per request. ~*consensus-enabled-p*~ enables multi-provider agreement.
|
||||
#+begin_src lisp
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *provider-cascade* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *model-selector-fn* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *consensus-enabled-p* nil)
|
||||
#+end_src
|
||||
|
||||
** Backend Registration (register-probabilistic-backend)
|
||||
#+begin_src lisp
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
#+end_src
|
||||
|
||||
** Cascade Dispatch (probabilistic-call)
|
||||
#+begin_src lisp
|
||||
(defun probabilistic-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(harness-log "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector-fn*
|
||||
(funcall *model-selector-fn* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(harness-log "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
#+end_src
|
||||
|
||||
** Cognitive Proposal Generation (Think)
|
||||
#+begin_src lisp
|
||||
(defun strip-markdown (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
|
||||
(defun normalize-plist-keywords (plist)
|
||||
(when (listp plist)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
|
||||
(defun think (context)
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness))
|
||||
(system-logs (context-get-system-logs))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
||||
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
||||
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(reflection-feedback (if rejection-trace
|
||||
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
||||
""))
|
||||
(skill-augments (let ((augments ""))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(let ((aug-fn (skill-system-prompt-augment skill)))
|
||||
(when aug-fn
|
||||
(let ((aug-text (ignore-errors (funcall aug-fn context))))
|
||||
(when (and aug-text (stringp aug-text) (> (length aug-text) 0))
|
||||
(setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
|
||||
*skills-registry*)
|
||||
(when (> (length augments) 0) augments)))
|
||||
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a"
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (strip-markdown thought)))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(normalize-plist-keywords parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
||||
#+end_src
|
||||
|
||||
** Deterministic Engine (Verification)
|
||||
#+begin_src lisp
|
||||
(defun deterministic-verify (proposed-action context)
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
||||
(harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from deterministic-verify next-action))
|
||||
(when next-action (setf current-action next-action))))))
|
||||
current-action))
|
||||
#+end_src
|
||||
|
||||
** Reason Gate (Stage 2)
|
||||
#+begin_src lisp
|
||||
(defun reason-gate (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
||||
(return-from reason-gate signal))
|
||||
(let ((retries 3)
|
||||
(current-signal (copy-tree signal))
|
||||
(last-rejection nil))
|
||||
(loop
|
||||
(when (<= retries 0)
|
||||
(setf (getf signal :approved-action) last-rejection)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (deterministic-verify candidate current-signal)))
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/pipeline-reason-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-pipeline-reason-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :opencortex-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
(clrhash opencortex::*skills-registry*)
|
||||
(opencortex::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (deterministic-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
#+end_src
|
||||
@@ -1,3 +0,0 @@
|
||||
#!/bin/bash
|
||||
# (The content here is a duplicate of the main opencortex.sh for literate consistency)
|
||||
# [Note: Implementation is already verified in the top-level script]
|
||||
@@ -1,276 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
||||
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
||||
|
||||
(defun VAULT-MASK-STRING (s) (declare (ignore s)) "[MASKED]")
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn system-prompt-augment)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"Tracks all discovered skill files and their loading state.")
|
||||
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic system-prompt-augment)
|
||||
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic
|
||||
:system-prompt-augment ,system-prompt-augment)))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Resolves transitive dependencies. Returns list of skill names in dependency order."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
||||
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
||||
(unless (string= d "") (push d dependencies))))
|
||||
(setf pos end)))))
|
||||
(values id (reverse dependencies))))
|
||||
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency."
|
||||
(let* ((org-files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(lisp-files (uiop:directory-files skills-dir "org-skill-*.lisp"))
|
||||
(files (append org-files lisp-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(progn
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
;; Don't overwrite dependency info from .org files
|
||||
(unless (gethash (string-downcase filename) adj)
|
||||
(setf (gethash (string-downcase filename) adj) nil)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps)))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected")
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun remove-in-package-forms (code-string)
|
||||
"Removes in-package forms so symbols get defined in skill package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(unless (uiop:string-prefix-p "(in-package" trimmed)
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun extract-tangle-target (line)
|
||||
"Extracts the value of the :tangle header."
|
||||
(let ((pos (search ":tangle" line)))
|
||||
(when pos
|
||||
(let ((rest (string-trim '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
||||
(let ((end (position #\Space rest)))
|
||||
(if end (subseq rest 0 end) rest))))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
||||
(setf in-lisp-block t)
|
||||
(let ((target (extract-tangle-target clean-line)))
|
||||
;; Collect if there's no tangle target (inherits from file)
|
||||
;; or if it's a lisp file and NOT a test.
|
||||
(setf collect-this-block (or (null target)
|
||||
(and (not (search "no" target))
|
||||
(not (search "/tests" target)))))))
|
||||
((uiop:string-prefix-p "#+end_src" clean-line)
|
||||
(setf in-lisp-block nil) (setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(if (= (length lisp-code) 0)
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(harness-log "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
;; Export symbols back to :OPENCORTEX for discoverability and testing
|
||||
(let* ((target-pkg (find-package :opencortex))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(harness-log "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DOCTOR-MAIN")
|
||||
(string-equal sn "RUN-SETUP-WIZARD"))
|
||||
(harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn)
|
||||
;; Resolve potential name conflicts by uninterning first
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
(error (c)
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
"Loads a .lisp skill file directly, filtering out in-package forms."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (remove-in-package-forms (uiop:read-file-string filepath)))
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax content)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(harness-log "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
;; Evaluate forms individually so one bad form doesn't abort the entire skill
|
||||
(with-input-from-string (s content)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (harness-log "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
;; Export symbols
|
||||
(let* ((target-pkg (find-package :opencortex))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(harness-log "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DOCTOR-MAIN")
|
||||
(string-equal sn "RUN-SETUP-WIZARD"))
|
||||
(harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun initialize-all-skills ()
|
||||
"Initializes all skills from the XDG skills directory."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "OC_DATA_DIR") (namestring (merge-pathnames ".local/share/opencortex/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "skills/" data-dir)))
|
||||
(unless (uiop:directory-exists-p skills-dir) (return-from initialize-all-skills nil))
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(harness-log "LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
(dolist (file sorted-files)
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(harness-log "LOADER: Boot Complete."))))
|
||||
@@ -1,373 +0,0 @@
|
||||
#+TITLE: The Skill Engine (skills.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:skills:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle skills.lisp
|
||||
|
||||
* Overview
|
||||
The Skill Engine is the dynamic loading and lifecycle manager for all OpenCortex skills. It discovers skill files in the skills directory, resolves their dependency order, loads them into jailed packages, exports their public symbols into the ~opencortex~ package, and provides the ~defskill~ macro that skills use to register themselves.
|
||||
|
||||
Key concepts:
|
||||
- ~defskill~ — macro that registers a skill with its trigger, deterministic gate, and optional probabilistic prompt
|
||||
- ~def-cognitive-tool~ — macro that registers a tool the LLM can invoke
|
||||
- ~load-skill-from-org~ / ~load-skill-from-lisp~ — load a skill from a literate Org file or a pre-tangled Lisp file
|
||||
- ~topological-sort-skills~ — orders skills by their ~#+DEPENDS_ON:~ declarations
|
||||
- ~find-triggered-skill~ — returns the highest-priority skill whose trigger matches the current context
|
||||
|
||||
The engine supports **hot-reload** — skills can be replaced at runtime without restarting the daemon.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Utility functions
|
||||
Helper functions used by the skill loader and other components.
|
||||
|
||||
*** Cosine similarity
|
||||
Computes the cosine similarity between two numeric vectors. Used by the peripheral vision system for semantic relevance scoring.
|
||||
#+begin_src lisp
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
||||
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
||||
#+end_src
|
||||
|
||||
*** Secret masking
|
||||
Simple mask function and the vault memory hash table. Used by the Bouncer skill and credentials vault.
|
||||
#+begin_src lisp
|
||||
(defun VAULT-MASK-STRING (s) (declare (ignore s)) "[MASKED]")
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
** Skill data structures
|
||||
The ~skill~ struct holds all metadata about a loaded skill: its name, priority, dependencies, trigger function, probabilistic prompt generator, deterministic gate, and system prompt augmentor. The ~skill-entry~ struct tracks the loading state of each discovered skill file.
|
||||
#+begin_src lisp
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn system-prompt-augment)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"Tracks all discovered skill files and their loading state.")
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
#+end_src
|
||||
|
||||
** Skill discovery (find-triggered-skill)
|
||||
Iterates the registry and returns the highest-priority skill whose trigger function matches the current context. Only skills with a probabilistic prompt are considered (skills that are purely deterministic don't need LLM intervention).
|
||||
#+begin_src lisp
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
#+end_src
|
||||
|
||||
** Skill registration macro (defskill)
|
||||
The primary API for skills. Each skill file calls this once to register itself. The macro creates a ~skill~ struct and stores it in ~*skills-registry*~ keyed by the skill's name.
|
||||
#+begin_src lisp
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic system-prompt-augment)
|
||||
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic
|
||||
:system-prompt-augment ,system-prompt-augment)))
|
||||
#+end_src
|
||||
|
||||
** Dependency resolution (resolve-skill-dependencies)
|
||||
Recursively resolves all transitive dependencies for a given skill, returning an ordered list. Uses a standard topological sort with cycle detection (a ~seen~ set prevents infinite recursion).
|
||||
#+begin_src lisp
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Resolves transitive dependencies. Returns list of skill names in dependency order."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
#+end_src
|
||||
|
||||
** Skill File Analysis (parse-skill-metadata)
|
||||
#+begin_src lisp
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
||||
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
||||
(unless (string= d "") (push d dependencies))))
|
||||
(setf pos end)))))
|
||||
(values id (reverse dependencies))))
|
||||
#+end_src
|
||||
|
||||
** Dependency Resolution (topological-sort-skills)
|
||||
#+begin_src lisp
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency."
|
||||
(let* ((org-files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(lisp-files (uiop:directory-files skills-dir "org-skill-*.lisp"))
|
||||
(files (append org-files lisp-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(progn
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
;; Don't overwrite dependency info from .org files
|
||||
(unless (gethash (string-downcase filename) adj)
|
||||
(setf (gethash (string-downcase filename) adj) nil)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps)))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected")
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
#+end_src
|
||||
|
||||
** Jailed Loading (load-skill-from-org)
|
||||
#+begin_src lisp
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun remove-in-package-forms (code-string)
|
||||
"Removes in-package forms so symbols get defined in skill package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(unless (uiop:string-prefix-p "(in-package" trimmed)
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun extract-tangle-target (line)
|
||||
"Extracts the value of the :tangle header."
|
||||
(let ((pos (search ":tangle" line)))
|
||||
(when pos
|
||||
(let ((rest (string-trim '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
||||
(let ((end (position #\Space rest)))
|
||||
(if end (subseq rest 0 end) rest))))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
||||
(setf in-lisp-block t)
|
||||
(let ((target (extract-tangle-target clean-line)))
|
||||
;; Collect if there's no tangle target (inherits from file)
|
||||
;; or if it's a lisp file and NOT a test.
|
||||
(setf collect-this-block (or (null target)
|
||||
(and (not (search "no" target))
|
||||
(not (search "/tests" target)))))))
|
||||
((uiop:string-prefix-p "#+end_src" clean-line)
|
||||
(setf in-lisp-block nil) (setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(if (= (length lisp-code) 0)
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(harness-log "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
;; Export symbols back to :OPENCORTEX for discoverability and testing
|
||||
(let* ((target-pkg (find-package :opencortex))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(harness-log "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DOCTOR-MAIN")
|
||||
(string-equal sn "RUN-SETUP-WIZARD"))
|
||||
(harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn)
|
||||
;; Resolve potential name conflicts by uninterning first
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
(error (c)
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
"Loads a .lisp skill file directly, filtering out in-package forms."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (remove-in-package-forms (uiop:read-file-string filepath)))
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax content)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(harness-log "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
;; Evaluate forms individually so one bad form doesn't abort the entire skill
|
||||
(with-input-from-string (s content)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (harness-log "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
;; Export symbols
|
||||
(let* ((target-pkg (find-package :opencortex))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(harness-log "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DOCTOR-MAIN")
|
||||
(string-equal sn "RUN-SETUP-WIZARD"))
|
||||
(harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
#+end_src
|
||||
|
||||
** Initialize (initialize-all-skills)
|
||||
#+begin_src lisp
|
||||
(defun initialize-all-skills ()
|
||||
"Initializes all skills from the XDG skills directory."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "OC_DATA_DIR") (namestring (merge-pathnames ".local/share/opencortex/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "skills/" data-dir)))
|
||||
(unless (uiop:directory-exists-p skills-dir) (return-from initialize-all-skills nil))
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(harness-log "LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
(dolist (file sorted-files)
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(harness-log "LOADER: Boot Complete."))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../tests/boot-sequence-tests.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :opencortex-boot-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :opencortex-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
(let ((tmp-dir "/tmp/opencortex-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (opencortex::topological-sort-skills tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
#+end_src
|
||||
@@ -1,147 +0,0 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :opencortex.tui)
|
||||
|
||||
(defvar *daemon-host* "127.0.0.1")
|
||||
(defvar *daemon-port* 9105)
|
||||
(defvar *socket* nil)
|
||||
(defvar *stream* nil)
|
||||
(defvar *chat-history* nil)
|
||||
(defvar *input-list* nil) ; List of characters (stored in reverse)
|
||||
(defvar *is-running* t)
|
||||
(defvar *queue-lock* (bt:make-lock))
|
||||
(defvar *incoming-msgs* nil)
|
||||
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/opencortex-tui-debug.log" :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format s "[~a] " (get-universal-time))
|
||||
(apply #'format s msg args)
|
||||
(terpri s)
|
||||
(finish-output s))))
|
||||
|
||||
(defun enqueue-msg (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming-msgs* (append *incoming-msgs* (list msg)))))
|
||||
|
||||
(defun dequeue-msgs ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming-msgs*))
|
||||
(setf *incoming-msgs* nil)
|
||||
msgs)))
|
||||
|
||||
(defun render-chat (win h)
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history (copy-list *chat-history*))
|
||||
(len (length history))
|
||||
(num-to-draw (min len view-height))
|
||||
(slice (subseq history 0 num-to-draw)))
|
||||
(loop for i from 0 below num-to-draw
|
||||
for msg in (reverse slice)
|
||||
do (when msg
|
||||
(add-string win (format nil "│ ~a" msg) :y (1+ i) :x 2))))
|
||||
(refresh win)))
|
||||
|
||||
(defun handle-backspace ()
|
||||
(pop *input-list*))
|
||||
|
||||
(defun handle-return (stream)
|
||||
(let ((cmd (coerce (reverse *input-list*) 'string)))
|
||||
(setf *input-list* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(push (format nil "⬆ ~a" cmd) *chat-history*)
|
||||
(handler-case
|
||||
(progn
|
||||
(if (and stream (open-stream-p stream))
|
||||
(let* ((msg (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui)
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
|
||||
(payload (format nil "~s" msg))
|
||||
(len (length payload)))
|
||||
(format stream "~6,'0x~a" len payload)
|
||||
(finish-output stream)
|
||||
(log-debug "SENT WIRE: ~a" payload))
|
||||
(push "ERROR: Not connected." *chat-history*)))
|
||||
(error (c)
|
||||
(log-debug "SEND ERROR: ~a" c)
|
||||
(push (format nil "ERROR: ~a" c) *chat-history*)
|
||||
(setf *is-running* nil))))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))))
|
||||
|
||||
(defun start-background-reader (stream)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(if (= count 6)
|
||||
(let* ((msg-len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string msg-len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(log-debug "DAEMON MSG: ~a" msg-buf)
|
||||
(let ((msg (read-from-string msg-buf)))
|
||||
(let ((payload (getf msg :payload)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(enqueue-msg "* Connected *"))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(enqueue-msg (format nil "⬇ ~a" text))))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(enqueue-msg "ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "opencortex-tui-reader"))
|
||||
|
||||
(defun main ()
|
||||
(log-debug "=== START ===")
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(chat-h (- h 4))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y 1 :x 1))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :y (- h 2) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(start-background-reader *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (dequeue-msgs)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(render-chat chat-win chat-h)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter) (eql ch #\Newline) (eql ch #\Return))
|
||||
(handle-return *stream*)
|
||||
(render-chat chat-win chat-h))
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(handle-backspace))
|
||||
((characterp ch)
|
||||
(push ch *input-list*))
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-list*))))))
|
||||
(clear input-win)
|
||||
(add-string input-win (format nil "▶ ~a" (coerce (reverse *input-list*) 'string)) :y 0 :x 1)
|
||||
(refresh input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
@@ -1,229 +0,0 @@
|
||||
#+TITLE: OpenCortex TUI Client (Standalone)
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :tui:ux:client:
|
||||
#+PROPERTY: header-args:lisp :tangle tui-client.lisp
|
||||
|
||||
* Overview
|
||||
The TUI Client is a standalone ncurses application (built on Croatoan) that connects to the daemon via TCP. It provides a split-pane interface: a scrollable chat history window and a fixed input line at the bottom. Connected to the daemon at ~localhost:9105~, it sends user input as framed protocol messages and displays responses as they arrive from the daemon's background reader thread.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :opencortex.tui)
|
||||
#+end_src
|
||||
|
||||
** Connection state
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-host* "localhost")
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-port* 9105)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *socket* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *stream* nil)
|
||||
#+end_src
|
||||
|
||||
** UI state
|
||||
#+begin_src lisp
|
||||
(defvar *chat-history* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *input-list* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *is-running* t)
|
||||
#+end_src
|
||||
|
||||
** Thread-safe message queue
|
||||
#+begin_src lisp
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *incoming-msgs* nil)
|
||||
#+end_src
|
||||
|
||||
** Utilities
|
||||
#+begin_src lisp
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/opencortex-tui-debug.log" :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format s "[~a] " (get-universal-time))
|
||||
(apply #'format s msg args)
|
||||
(terpri s)
|
||||
(finish-output s))))
|
||||
|
||||
(defun enqueue-msg (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming-msgs* (append *incoming-msgs* (list msg)))))
|
||||
|
||||
(defun dequeue-msgs ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming-msgs*))
|
||||
(setf *incoming-msgs* nil)
|
||||
msgs)))
|
||||
#+end_src
|
||||
|
||||
** Rendering
|
||||
#+begin_src lisp
|
||||
(defun render-chat (win h)
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history (copy-list *chat-history*))
|
||||
(len (length history))
|
||||
(num-to-draw (min len view-height))
|
||||
(slice (subseq history 0 num-to-draw)))
|
||||
(loop for i from 0 below num-to-draw
|
||||
for msg in (reverse slice)
|
||||
do (when msg
|
||||
(add-string win (format nil "│ ~a" msg) :y (1+ i) :x 2))))
|
||||
(refresh win)))
|
||||
#+end_src
|
||||
|
||||
** Input Handling
|
||||
#+begin_src lisp
|
||||
(defun handle-backspace ()
|
||||
(pop *input-list*))
|
||||
|
||||
(defun handle-return (stream)
|
||||
(let ((cmd (coerce (reverse *input-list*) 'string)))
|
||||
(setf *input-list* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(push (format nil "⬆ ~a" cmd) *chat-history*)
|
||||
(handler-case
|
||||
(progn
|
||||
(if (and stream (open-stream-p stream))
|
||||
(let* ((msg (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui)
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
|
||||
(payload (format nil "~s" msg))
|
||||
(len (length payload)))
|
||||
(format stream "~6,'0x~a" len payload)
|
||||
(finish-output stream)
|
||||
(log-debug "SENT WIRE: ~a" payload))
|
||||
(push "ERROR: Not connected." *chat-history*)))
|
||||
(error (c)
|
||||
(log-debug "SEND ERROR: ~a" c)
|
||||
(push (format nil "ERROR: ~a" c) *chat-history*)
|
||||
(setf *is-running* nil))))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))))
|
||||
#+end_src
|
||||
|
||||
** Background Reader
|
||||
#+begin_src lisp
|
||||
(defun start-background-reader (stream)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(if (= count 6)
|
||||
(let* ((msg-len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string msg-len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(log-debug "DAEMON MSG: ~a" msg-buf)
|
||||
(let ((msg (read-from-string msg-buf)))
|
||||
(let ((payload (getf msg :payload)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(enqueue-msg "* Connected *"))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(enqueue-msg (format nil "⬇ ~a" text))))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(enqueue-msg "ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "opencortex-tui-reader"))
|
||||
#+end_src
|
||||
|
||||
** Main Entry Point
|
||||
#+begin_src lisp
|
||||
(defun main ()
|
||||
(log-debug "=== START ===")
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(chat-h (- h 4))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y 1 :x 1))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :y (- h 2) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(start-background-reader *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (dequeue-msgs)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(render-chat chat-win chat-h)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter) (eql ch #\Newline) (eql ch #\Return))
|
||||
(handle-return *stream*)
|
||||
(render-chat chat-win chat-h))
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(handle-backspace))
|
||||
((characterp ch)
|
||||
(push ch *input-list*))
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-list*))))))
|
||||
(clear input-win)
|
||||
(add-string input-win (format nil "▶ ~a" (coerce (reverse *input-list*) 'string)) :y 0 :x 1)
|
||||
(refresh input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
#+end_src
|
||||
|
||||
** REPL test script (tmux)
|
||||
Use this script to test the TUI non-interactively in a tmux session. It launches the TUI in a headless tmux window, sends text, and captures the output.
|
||||
|
||||
#+begin_src bash :tangle no
|
||||
#!/bin/bash
|
||||
SESSION="oct-tui-test"
|
||||
tmux new-session -d -s "$SESSION" \
|
||||
-e OC_CONFIG_DIR="$HOME/.config/opencortex" \
|
||||
-e OC_DATA_DIR="$HOME/.local/share/opencortex" \
|
||||
-e TERM="screen-256color" \
|
||||
"sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames \"quicklisp/setup.lisp\" (user-homedir-pathname)))' \
|
||||
--eval '(push (truename \"$HOME/.local/share/opencortex/\") asdf:*central-registry*)' \
|
||||
--eval '(ql:quickload :opencortex/tui)' \
|
||||
--eval '(opencortex.tui:main)'"
|
||||
sleep 5
|
||||
tmux capture-pane -t "$SESSION" -p -S -20
|
||||
tmux send-keys -t "$SESSION" 'hello' Enter
|
||||
sleep 8
|
||||
tmux capture-pane -t "$SESSION" -p -S -20
|
||||
tmux send-keys -t "$SESSION" '/exit' Enter
|
||||
sleep 1
|
||||
tmux kill-session -t "$SESSION" 2>/dev/null || true
|
||||
#+end_src
|
||||
@@ -16,8 +16,8 @@ RUN curl -O https://beta.quicklisp.org/quicklisp.lisp \
|
||||
WORKDIR /app
|
||||
COPY . .
|
||||
|
||||
RUN mkdir -p /root/memex && ./opencortex.sh configure --non-interactive
|
||||
RUN mkdir -p /root/memex && ./passepartout.sh configure --non-interactive
|
||||
|
||||
EXPOSE 9105
|
||||
|
||||
CMD ["./opencortex.sh", "daemon"]
|
||||
CMD ["./passepartout.sh", "daemon"]
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
services:
|
||||
opencortex:
|
||||
passepartout:
|
||||
build:
|
||||
context: ../../
|
||||
dockerfile: infrastructure/docker/Dockerfile
|
||||
container_name: opencortex
|
||||
container_name: passepartout
|
||||
env_file: ../../.env
|
||||
volumes:
|
||||
- ../../../..:/memex
|
||||
|
||||
@@ -1,15 +0,0 @@
|
||||
[Unit]
|
||||
Description=OpenCortex Daemon
|
||||
Documentation=https://github.com/amrgharbeia/opencortex
|
||||
After=network.target
|
||||
|
||||
[Service]
|
||||
Type=simple
|
||||
User=%u
|
||||
ExecStart=%h/projects/opencortex/opencortex.sh daemon
|
||||
Restart=on-failure
|
||||
RestartSec=10
|
||||
WorkingDirectory=%h/projects/opencortex
|
||||
|
||||
[Install]
|
||||
WantedBy=default.target
|
||||
15
infrastructure/passepartout.service
Normal file
15
infrastructure/passepartout.service
Normal file
@@ -0,0 +1,15 @@
|
||||
[Unit]
|
||||
Description=Passepartout Daemon
|
||||
Documentation=https://github.com/amrgharbeia/passepartout
|
||||
After=network.target
|
||||
|
||||
[Service]
|
||||
Type=simple
|
||||
User=%u
|
||||
ExecStart=%h/projects/passepartout/passepartout daemon
|
||||
Restart=on-failure
|
||||
RestartSec=10
|
||||
WorkingDirectory=%h/projects/passepartout
|
||||
|
||||
[Install]
|
||||
WantedBy=default.target
|
||||
@@ -1,38 +0,0 @@
|
||||
(defsystem :opencortex
|
||||
:name "opencortex"
|
||||
:author "Amr Gharbeia"
|
||||
:version "0.2.0"
|
||||
:license "AGPLv3"
|
||||
:description "The Probabilistic-Deterministic Lisp Machine"
|
||||
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
|
||||
:serial t
|
||||
:components ((:file "harness/package")
|
||||
(:file "harness/skills")
|
||||
(:file "harness/communication")
|
||||
(:file "harness/communication-validator")
|
||||
(:file "harness/memory")
|
||||
(:file "harness/context")
|
||||
(:file "harness/perceive")
|
||||
(:file "harness/reason")
|
||||
(:file "harness/act")
|
||||
(:file "harness/doctor")
|
||||
(:file "harness/loop")))
|
||||
|
||||
(defsystem :opencortex/tests
|
||||
:depends-on (:opencortex :fiveam)
|
||||
:components ((:file "tests/pipeline-act-tests")
|
||||
(:file "tests/boot-sequence-tests")
|
||||
(:file "tests/communication-tests")
|
||||
(:file "tests/immune-system-tests")
|
||||
(:file "tests/memory-tests")
|
||||
(:file "tests/pipeline-perceive-tests")
|
||||
(:file "tests/pipeline-reason-tests")
|
||||
(:file "tests/peripheral-vision-tests")
|
||||
(:file "tests/tui-tests")
|
||||
(:file "tests/utils-org-tests")
|
||||
(:file "tests/utils-lisp-tests")
|
||||
(:file "tests/llm-gateway-tests")))
|
||||
|
||||
(defsystem :opencortex/tui
|
||||
:depends-on (:opencortex :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "harness/tui-client")))
|
||||
469
opencortex.sh
469
opencortex.sh
@@ -1,469 +0,0 @@
|
||||
#!/bin/bash
|
||||
set -e
|
||||
|
||||
PORT=9105
|
||||
HOST="localhost"
|
||||
RED='\033[0;31m'; GREEN='\033[0;32m'; BLUE='\033[0;34m'; YELLOW='\033[0;33m'; NC='\033[0m'
|
||||
|
||||
command_exists() { command -v "$1" >/dev/null 2>&1; }
|
||||
|
||||
# --- XDG PATH RESOLUTION ---
|
||||
SOURCE="${BASH_SOURCE[0]}"
|
||||
while [ -h "$SOURCE" ]; do
|
||||
DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
|
||||
SOURCE="$(readlink "$SOURCE")"
|
||||
[[ $SOURCE != /* ]] && SOURCE="$DIR/$SOURCE"
|
||||
done
|
||||
export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
|
||||
|
||||
export OC_CONFIG_DIR="$(realpath -m "${XDG_CONFIG_HOME:-$HOME/.config}/opencortex")"
|
||||
export OC_DATA_DIR="$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/opencortex")"
|
||||
export OC_STATE_DIR="$(realpath -m "${XDG_STATE_HOME:-$HOME/.local/state}/opencortex")"
|
||||
export OC_BIN_DIR="$(realpath -m "${XDG_BIN_HOME:-$HOME/.local/bin}")"
|
||||
export MEMEX_DIR="${MEMEX_DIR:-$HOME/memex}"
|
||||
|
||||
if [ -f "$OC_CONFIG_DIR/.env" ]; then
|
||||
set -a; source "$OC_CONFIG_DIR/.env"; set +a
|
||||
fi
|
||||
|
||||
# --- DISTRO DETECTION ---
|
||||
detect_distro() {
|
||||
if [ -f /etc/os-release ]; then
|
||||
. /etc/os-release
|
||||
case "$ID" in
|
||||
debian|ubuntu|linuxmint|pop|elementary|zorin) echo "debian" ;;
|
||||
fedora|rhel|centos|rocky|almalinux) echo "fedora" ;;
|
||||
*) echo "unknown" ;;
|
||||
esac
|
||||
elif command_exists apt-get; then echo "debian"
|
||||
elif command_exists dnf; then echo "fedora"
|
||||
else echo "unknown"; fi
|
||||
}
|
||||
|
||||
distro_install() {
|
||||
local distro=$(detect_distro); shift
|
||||
case "$distro" in
|
||||
debian) sudo apt-get update && sudo apt-get install -y "$@" ;;
|
||||
fedora) sudo dnf install -y "$@" ;;
|
||||
*) echo "Unsupported distro. Install manually: sbcl emacs git curl socat"; return 1 ;;
|
||||
esac
|
||||
}
|
||||
|
||||
# --- DEPENDENCY CHECK ---
|
||||
check_dependencies() {
|
||||
local missing=()
|
||||
for dep in sbcl git curl socat nc; do
|
||||
if ! command_exists "$dep"; then missing+=("$dep"); fi
|
||||
done
|
||||
if ! command_exists emacs; then missing+=("emacs-nox"); fi
|
||||
if [ ${#missing[@]} -gt 0 ]; then
|
||||
echo -e "${YELLOW}--- Installing missing dependencies: ${missing[*]} ---${NC}"
|
||||
local distro=$(detect_distro)
|
||||
case "$distro" in
|
||||
debian)
|
||||
distro_install "${missing[@]}" libssl-dev libncurses-dev libffi-dev zlib1g-dev libsqlite3-dev 2>/dev/null || true
|
||||
if ! command_exists rlwrap; then distro_install rlwrap 2>/dev/null || true; fi
|
||||
if ! command_exists nc; then distro_install netcat-openbsd 2>/dev/null || true; fi
|
||||
;;
|
||||
fedora)
|
||||
distro_install "${missing[@]}" openssl-devel ncurses-devel libffi-devel zlib-devel sqlite-devel 2>/dev/null || true
|
||||
if ! command_exists rlwrap; then distro_install rlwrap 2>/dev/null || true; fi
|
||||
if ! command_exists nc; then distro_install nmap-ncat 2>/dev/null || true; fi
|
||||
;;
|
||||
esac
|
||||
fi
|
||||
}
|
||||
|
||||
# --- SETUP ---
|
||||
setup_system() {
|
||||
NON_INTERACTIVE=false; WITH_FIREWALL=false
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
--non-interactive) NON_INTERACTIVE=true ;;
|
||||
--with-firewall) WITH_FIREWALL=true ;;
|
||||
esac
|
||||
done
|
||||
|
||||
echo -e "${BLUE}=== OpenCortex: Configure ===${NC}"
|
||||
mkdir -p "$OC_CONFIG_DIR" "$OC_DATA_DIR" "$OC_STATE_DIR" "$OC_BIN_DIR"
|
||||
mkdir -p "$OC_DATA_DIR/harness" "$OC_DATA_DIR/tests" "$OC_DATA_DIR/skills"
|
||||
|
||||
check_dependencies
|
||||
|
||||
if [ ! -d "$HOME/quicklisp" ]; then
|
||||
echo -e "${YELLOW}--- Installing Quicklisp ---${NC}"
|
||||
curl -O https://beta.quicklisp.org/quicklisp.lisp
|
||||
sbcl --non-interactive --load quicklisp.lisp \
|
||||
--eval "(quicklisp-quickstart:install)" \
|
||||
--eval "(ql-util:without-prompting (ql:add-to-init-file))"
|
||||
rm quicklisp.lisp
|
||||
fi
|
||||
|
||||
echo -e "${YELLOW}--- Deploying Engine to $OC_DATA_DIR ---${NC}"
|
||||
cp "$SCRIPT_DIR/opencortex.asd" "$OC_DATA_DIR/"
|
||||
mkdir -p "$OC_DATA_DIR/harness" "$OC_DATA_DIR/tests" "$OC_DATA_DIR/skills"
|
||||
export INSTALL_DIR="$OC_DATA_DIR"
|
||||
|
||||
cp "$SCRIPT_DIR/harness"/*.org "$OC_DATA_DIR/harness/"
|
||||
(cd "$OC_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"manifest.org\")") >/dev/null 2>&1 || true
|
||||
for f in "$OC_DATA_DIR/harness"/*.org; do
|
||||
fname=$(basename "$f" .org)
|
||||
[ "$fname" = "manifest" ] && continue
|
||||
echo "Tangling harness/$fname.org..."
|
||||
(cd "$OC_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
done
|
||||
find "$OC_DATA_DIR/harness" -name "*-tests.lisp" -exec mv {} "$OC_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
rm -f "$OC_DATA_DIR/harness"/*.org
|
||||
|
||||
for f in "$SCRIPT_DIR/skills"/*.org; do
|
||||
fname=$(basename "$f" .org)
|
||||
echo "Tangling skills/$fname.org..."
|
||||
cp "$f" "$OC_DATA_DIR/skills/"
|
||||
(cd "$OC_DATA_DIR/skills" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
rm -f "$OC_DATA_DIR/skills/$fname.org"
|
||||
done
|
||||
find "$OC_DATA_DIR/skills" -name "*-tests.lisp" -exec mv {} "$OC_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
[ -f "$OC_DATA_DIR/run-all-tests.lisp" ] && mv "$OC_DATA_DIR/run-all-tests.lisp" "$OC_DATA_DIR/harness/"
|
||||
rm -f "$OC_DATA_DIR/harness"/*.org "$OC_DATA_DIR/skills"/*.org
|
||||
|
||||
ln -sf "$SCRIPT_DIR/opencortex.sh" "$OC_BIN_DIR/opencortex"
|
||||
|
||||
if [ "$WITH_FIREWALL" = true ]; then
|
||||
case $(detect_distro) in
|
||||
debian) sudo ufw allow 9105/tcp 2>/dev/null && echo "✓ UFW: port 9105 opened" || true ;;
|
||||
fedora) sudo firewall-cmd --add-port=9105/tcp --permanent 2>/dev/null && sudo firewall-cmd --reload 2>/dev/null && echo "✓ firewalld: port 9105 opened" || true ;;
|
||||
esac
|
||||
fi
|
||||
|
||||
if [ "$NON_INTERACTIVE" = true ]; then
|
||||
echo "Configure complete."
|
||||
exit 0
|
||||
fi
|
||||
|
||||
echo -e "${YELLOW}--- Launching Setup Wizard ---${NC}"
|
||||
exec sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval '(funcall (find-symbol "RUN-SETUP-WIZARD" :opencortex))'
|
||||
}
|
||||
|
||||
# --- DOCTOR REPAIR ---
|
||||
doctor_repair() {
|
||||
echo -e "${BLUE}=== OpenCortex: Repair Mode ===${NC}"
|
||||
check_dependencies
|
||||
mkdir -p "$OC_CONFIG_DIR" "$OC_DATA_DIR" "$OC_STATE_DIR" "$OC_BIN_DIR"
|
||||
mkdir -p "$OC_DATA_DIR/harness" "$OC_DATA_DIR/tests" "$OC_DATA_DIR/skills"
|
||||
for f in "$SCRIPT_DIR/harness"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking harness/$fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$OC_DATA_DIR/harness/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
(cd "$OC_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$f\")") >/dev/null 2>&1 || true
|
||||
fi
|
||||
done
|
||||
for f in "$SCRIPT_DIR/skills"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking skill/$fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$OC_DATA_DIR/skills/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
cp "$f" "$OC_DATA_DIR/skills/"
|
||||
(cd "$OC_DATA_DIR/skills" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
rm -f "$OC_DATA_DIR/skills/$fname.org"
|
||||
fi
|
||||
done
|
||||
rm -f "$OC_DATA_DIR/harness"/*.org "$OC_DATA_DIR/skills"/*.org 2>/dev/null || true
|
||||
echo -e "${GREEN}--- Repair Complete ---${NC}"
|
||||
}
|
||||
|
||||
# --- INSTALL SKILL ---
|
||||
install_skill() {
|
||||
local SKILL_NAME=$1
|
||||
if [ -z "$SKILL_NAME" ]; then
|
||||
echo "Usage: opencortex install skill <skill-name>"
|
||||
echo " Installs a skill from opencortex-contrib"
|
||||
echo ""
|
||||
echo "Available skills:"
|
||||
if [ -d "$MEMEX_DIR/projects/opencortex-contrib/skills" ]; then
|
||||
ls "$MEMEX_DIR/projects/opencortex-contrib/skills"/*.org 2>/dev/null | xargs -I{} basename {} .org | sed 's/org-skill-//' | sort | uniq
|
||||
else
|
||||
echo " (clone opencortex-contrib to ~/memex/projects/ first)"
|
||||
fi
|
||||
exit 1
|
||||
fi
|
||||
local SKILL_FILE="org-skill-${SKILL_NAME}.org"
|
||||
local SOURCE_DIR="$MEMEX_DIR/projects/opencortex-contrib/skills"
|
||||
local TARGET_DIR="$OC_DATA_DIR/skills"
|
||||
if [ ! -d "$SOURCE_DIR" ]; then
|
||||
echo "Error: Contrib skills not found at $SOURCE_DIR"
|
||||
echo "Run: git clone https://github.com/amrgharbeia/opencortex-contrib.git \$MEMEX_DIR/projects/opencortex-contrib"
|
||||
exit 1
|
||||
fi
|
||||
if [ ! -f "$SOURCE_DIR/$SKILL_FILE" ]; then
|
||||
echo "Error: Skill '$SKILL_NAME' not found"
|
||||
exit 1
|
||||
fi
|
||||
mkdir -p "$TARGET_DIR"
|
||||
cp "$SOURCE_DIR/$SKILL_FILE" "$TARGET_DIR/"
|
||||
(cd "$TARGET_DIR" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$SKILL_FILE\")") >/dev/null 2>&1 || true
|
||||
rm -f "$TARGET_DIR/$SKILL_FILE"
|
||||
if [ -f "$TARGET_DIR/${SKILL_NAME}-tests.lisp" ]; then
|
||||
mv "$TARGET_DIR/${SKILL_NAME}-tests.lisp" "$OC_DATA_DIR/tests/" 2>/dev/null || true
|
||||
fi
|
||||
echo "Skill '$SKILL_NAME' installed. Restart to activate."
|
||||
}
|
||||
|
||||
# --- INSTALL SERVICE ---
|
||||
install_service() {
|
||||
mkdir -p "$HOME/.config/systemd/user"
|
||||
cat > "$HOME/.config/systemd/user/opencortex.service" << 'SERVICEEOF'
|
||||
[Unit]
|
||||
Description=OpenCortex Daemon
|
||||
After=network.target
|
||||
|
||||
[Service]
|
||||
Type=simple
|
||||
ExecStart=%h/projects/opencortex/opencortex.sh daemon
|
||||
Restart=on-failure
|
||||
RestartSec=10
|
||||
WorkingDirectory=%h/projects/opencortex
|
||||
|
||||
[Install]
|
||||
WantedBy=default.target
|
||||
SERVICEEOF
|
||||
systemctl --user daemon-reload
|
||||
systemctl --user enable opencortex.service
|
||||
systemctl --user start opencortex.service
|
||||
echo -e "${GREEN}✓ opencortex.service installed and started${NC}"
|
||||
echo " Status: systemctl --user status opencortex.service"
|
||||
echo " Logs: journalctl --user -u opencortex.service -f"
|
||||
}
|
||||
|
||||
uninstall_service() {
|
||||
systemctl --user stop opencortex.service 2>/dev/null || true
|
||||
systemctl --user disable opencortex.service 2>/dev/null || true
|
||||
rm -f "$HOME/.config/systemd/user/opencortex.service"
|
||||
systemctl --user daemon-reload
|
||||
echo -e "${GREEN}✓ opencortex.service removed${NC}"
|
||||
}
|
||||
|
||||
# --- BACKUP ---
|
||||
backup() {
|
||||
local dest="${1:-$HOME/opencortex-backup-$(date +%Y%m%d-%H%M%S).tar.gz}"
|
||||
if [ -f "$dest" ]; then echo "Error: $dest exists"; exit 1; fi
|
||||
echo "Backing up to $dest..."
|
||||
tar -czf "$dest" \
|
||||
"$OC_CONFIG_DIR" "$OC_DATA_DIR" \
|
||||
"$MEMEX_DIR/gtd.org" "$MEMEX_DIR/projects/opencortex" \
|
||||
2>/dev/null || true
|
||||
echo -e "${GREEN}✓ Backed up to $dest${NC}"
|
||||
}
|
||||
|
||||
restore() {
|
||||
local src="$1"
|
||||
if [ -z "$src" ] || [ ! -f "$src" ]; then
|
||||
echo "Usage: opencortex restore <backup-file>"
|
||||
exit 1
|
||||
fi
|
||||
echo "Restoring from $src..."
|
||||
tar -xzf "$src" -C /
|
||||
echo -e "${GREEN}✓ Restored. Run 'opencortex doctor' to verify.${NC}"
|
||||
}
|
||||
|
||||
# --- HELP ---
|
||||
help() {
|
||||
echo ""
|
||||
echo "OpenCortex — Your Autonomous, Plain-Text Life Assistant"
|
||||
echo ""
|
||||
echo "Usage: opencortex.sh <command> [options]"
|
||||
echo ""
|
||||
echo "System:"
|
||||
echo " configure [--non-interactive] [--with-firewall] Install or reconfigure the system"
|
||||
echo " setup Alias for configure"
|
||||
echo " doctor [--fix] [--watch] System health check"
|
||||
echo ""
|
||||
echo "Running:"
|
||||
echo " daemon Start background daemon"
|
||||
echo " tui Launch terminal UI"
|
||||
echo " gateway {link|unlink|list} <platform> <token> Manage chat gateways"
|
||||
echo ""
|
||||
echo "Skills:"
|
||||
echo " install skill <name> Install a skill from contrib"
|
||||
echo " install service Install systemd service (auto-start)"
|
||||
echo " uninstall service Remove systemd service"
|
||||
echo ""
|
||||
echo "Data:"
|
||||
echo " backup [path] Backup config, data, memex"
|
||||
echo " restore <path> Restore from a backup"
|
||||
echo ""
|
||||
echo "Quick start:"
|
||||
echo " curl -fsSL https://raw.githubusercontent.com/amrgharbeia/opencortex/main/opencortex.sh | bash -s configure"
|
||||
echo ""
|
||||
}
|
||||
|
||||
# --- COMMAND ROUTER ---
|
||||
COMMAND=$1; [ -z "$COMMAND" ] && COMMAND="help"
|
||||
shift || true
|
||||
|
||||
case "$COMMAND" in
|
||||
configure|setup)
|
||||
check_dependencies
|
||||
if [ "$1" = "--add-provider" ]; then
|
||||
sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval '(funcall (find-symbol "SETUP-ADD-PROVIDER" :opencortex))'
|
||||
elif [ "$1" = "--link" ]; then
|
||||
exec "$0" gateway link "$2" "$3"
|
||||
else
|
||||
setup_system "$@"
|
||||
fi
|
||||
;;
|
||||
doctor)
|
||||
check_dependencies
|
||||
if [ "$1" = "--watch" ]; then
|
||||
while true; do
|
||||
echo "--- $(date '+%Y-%m-%d %H:%M:%S') ---"
|
||||
sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval '(funcall (find-symbol "DOCTOR-RUN-ALL" :opencortex))' 2>&1 | grep -E "(HEALTH|OK|FAIL|WARN|SYSTEM|===)" || true
|
||||
sleep 60
|
||||
done
|
||||
elif [ "$1" = "--fix" ]; then
|
||||
if [ ! -f "$OC_DATA_DIR/harness/package.lisp" ] || [ ! -f "$OC_DATA_DIR/harness/skills.lisp" ]; then
|
||||
setup_system "$@"
|
||||
else
|
||||
doctor_repair
|
||||
fi
|
||||
else
|
||||
exec sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval '(funcall (find-symbol "DOCTOR-MAIN" :opencortex))'
|
||||
fi
|
||||
;;
|
||||
daemon)
|
||||
check_dependencies
|
||||
echo "Starting daemon in background..."
|
||||
nohup sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval "(ql:quickload '(:opencortex :croatoan))" \
|
||||
--eval '(opencortex:main)' \
|
||||
> "$OC_STATE_DIR/daemon.log" 2>&1 &
|
||||
echo "Waiting for port 9105..."
|
||||
for i in $(seq 1 20); do
|
||||
if ss -tln 2>/dev/null | grep -q 9105 || netstat -tln 2>/dev/null | grep -q 9105; then
|
||||
echo "✓ Daemon ready on port 9105"; exit 0
|
||||
fi
|
||||
sleep 1
|
||||
done
|
||||
echo "✗ Daemon failed to start. Check $OC_STATE_DIR/daemon.log"; exit 1
|
||||
;;
|
||||
tui)
|
||||
check_dependencies
|
||||
if ! ss -tln 2>/dev/null | grep -q 9105 && ! netstat -tln 2>/dev/null | grep -q 9105; then
|
||||
echo "Starting daemon first..."
|
||||
$0 daemon
|
||||
fi
|
||||
sbcl \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex/tui)' \
|
||||
--eval '(opencortex.tui:main)' || {
|
||||
echo "TUI error. Run 'opencortex doctor --fix'"; exit 1
|
||||
}
|
||||
;;
|
||||
gateway)
|
||||
SUBCMD=$1; PLATFORM=$2; TOKEN=$3
|
||||
check_dependencies
|
||||
case "$SUBCMD" in
|
||||
list)
|
||||
exec sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval '(funcall (find-symbol "GATEWAY-LIST-PRINT" (find-package "OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER")))'
|
||||
;;
|
||||
link)
|
||||
[ -z "$PLATFORM" ] || [ -z "$TOKEN" ] && echo "Usage: opencortex gateway link <platform> <token>" && exit 1
|
||||
exec sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-LINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\" \"$TOKEN\")"
|
||||
;;
|
||||
unlink)
|
||||
[ -z "$PLATFORM" ] && echo "Usage: opencortex gateway unlink <platform>" && exit 1
|
||||
exec sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :opencortex)' \
|
||||
--eval '(opencortex:initialize-all-skills)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-UNLINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\")"
|
||||
;;
|
||||
*) echo "Usage: opencortex gateway {list|link|unlink}"; exit 1 ;;
|
||||
esac
|
||||
;;
|
||||
install)
|
||||
case "$1" in
|
||||
skill) shift; install_skill "$@" ;;
|
||||
service) install_service ;;
|
||||
*) echo "Usage: opencortex install {skill|service}" >&2; exit 1 ;;
|
||||
esac
|
||||
;;
|
||||
uninstall)
|
||||
case "$1" in
|
||||
service) uninstall_service ;;
|
||||
*) echo "Usage: opencortex uninstall {service}" >&2; exit 1 ;;
|
||||
esac
|
||||
;;
|
||||
backup)
|
||||
backup "$1"
|
||||
;;
|
||||
restore)
|
||||
restore "$1"
|
||||
;;
|
||||
help|--help|-h)
|
||||
help
|
||||
;;
|
||||
*)
|
||||
echo "Unknown command: $COMMAND"
|
||||
help
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
72
org/channel-cli.org
Normal file
72
org/channel-cli.org
Normal file
@@ -0,0 +1,72 @@
|
||||
#+TITLE: SKILL: CLI Gateway (org-skill-cli-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:gateway:cli:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-cli.lisp
|
||||
|
||||
* Overview
|
||||
The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout over TCP. It connects to the daemon's framed protocol and translates between terminal input/output and the plist-based communication format. No TUI, no ncurses, no dependencies beyond a TCP socket. Every other gateway (TUI, Emacs, Telegram) builds on this same protocol.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (channel-cli-input text): wraps text in a ~:user-input~ envelope
|
||||
with ~:source :CLI~ and injects into the pipeline via
|
||||
~stimulus-inject~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** CLI Command Handling
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun channel-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-channel-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-channel-cli-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:cli-suite))
|
||||
|
||||
(in-package :passepartout-channel-cli-tests)
|
||||
|
||||
(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway")
|
||||
(fiveam:in-suite cli-suite)
|
||||
|
||||
(fiveam:test test-channel-cli-input-format
|
||||
"Contract 1: channel-cli-input injects a properly formed signal without error."
|
||||
(handler-case
|
||||
(progn (channel-cli-input "hello") (fiveam:pass))
|
||||
(error (c)
|
||||
(fiveam:fail "channel-cli-input crashed: ~a" c))))
|
||||
#+end_src
|
||||
|
||||
** Load-Time Sanity Check
|
||||
|
||||
Verifies the function exists and can be called at load time without
|
||||
depending on FiveAM macro resolution in the jailed package.
|
||||
|
||||
#+begin_src lisp
|
||||
(handler-case
|
||||
(progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK"))
|
||||
(error (c) (log-message "CLI: Load-time test FAILED: ~a" c)))
|
||||
#+end_src
|
||||
90
org/channel-discord.org
Normal file
90
org/channel-discord.org
Normal file
@@ -0,0 +1,90 @@
|
||||
#+TITLE: Channel Discord (channel-discord.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :channel:discord:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-discord.lisp
|
||||
|
||||
* Channel Discord
|
||||
|
||||
Extracted from gateway-messaging in v0.5.0. Isolated platform — Discord-specific poll and send logic.
|
||||
|
||||
* Overview
|
||||
|
||||
The Discord channel provides bidirectional communication via the Discord REST API
|
||||
and Gateway WebSocket. Messages received from Discord channels are injected into
|
||||
the cognitive pipeline as ~:user-input~ signals with ~:source :discord~. Outbound
|
||||
messages route through the actuator registry when the pipeline targets ~:discord~.
|
||||
|
||||
The channel uses two functions: ~discord-poll~ (inbound sensor, REST polling)
|
||||
and ~discord-send~ (outbound actuator, REST POST). Both retrieve the bot token
|
||||
from the credentials vault (~vault-get-secret :discord~). HITL commands are
|
||||
intercepted before injection so approval flows work identically across all channels.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (discord-get-token): returns the Discord bot token from the vault
|
||||
(via ~vault-get-secret :discord~), or nil if not configured.
|
||||
2. (discord-poll): polls configured channels via GET /channels/{id}/messages,
|
||||
injects each non-bot message as a ~:user-input~ stimulus with
|
||||
~:source :discord~. Handles JSON parse failures and API errors
|
||||
gracefully. HITL commands are intercepted before injection.
|
||||
3. (discord-send action context): sends a message via POST /channels/{id}/messages.
|
||||
Extracts ~:channel-id~ and ~:text~ from the action plist. Uses bot token
|
||||
authentication. Logs send failures without crashing the pipeline.
|
||||
|
||||
* Implementation
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(defun discord-get-token ()
|
||||
(vault-get-secret :discord))
|
||||
|
||||
(defun discord-send (action context)
|
||||
"Sends a message via Discord REST API."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(channel-id (or (getf meta :channel-id) (getf payload :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (discord-get-token)))
|
||||
(when (and token channel-id text)
|
||||
(handler-case
|
||||
(dex:post (format nil "https://discord.com/api/v10/channels/~a/messages" channel-id)
|
||||
:headers '(("Authorization" . ,(format nil "Bot ~a" token))
|
||||
("Content-Type" . "application/json"))
|
||||
:content (cl-json:encode-json-to-string
|
||||
`((content . ,text))))
|
||||
(error (c) (log-message "DISCORD ERROR: ~a" c))))))
|
||||
|
||||
(defun discord-poll ()
|
||||
"Polls Discord via HTTP GET /channels/{id}/messages. In production,
|
||||
a WebSocket connection to the Gateway is preferred for real-time events."
|
||||
(let* ((token (discord-get-token)))
|
||||
(when token
|
||||
(handler-case
|
||||
(dolist (channel '("channel-id-here")) ;; configured channel IDs
|
||||
(let* ((last-id (getf (gethash "discord" *gateway-configs*) :last-update-id 0))
|
||||
(url (format nil "https://discord.com/api/v10/channels/~a/messages?after=~a"
|
||||
channel last-id))
|
||||
(response (dex:get url :headers
|
||||
`(("Authorization" . ,(format nil "Bot ~a" token))))))
|
||||
(let ((messages (ignore-errors
|
||||
(cdr (assoc :message
|
||||
(cl-json:decode-json-from-string response))))))
|
||||
(dolist (msg (and (listp messages) messages))
|
||||
(let* ((id (cdr (assoc :id msg)))
|
||||
(content (cdr (assoc :content msg)))
|
||||
(author (cdr (assoc :author msg)))
|
||||
(author-id (cdr (assoc :id author)))
|
||||
(is-bot (cdr (assoc :bot author))))
|
||||
(when (and id content (not is-bot))
|
||||
(setf (getf (gethash "discord" *gateway-configs*) :last-update-id) id)
|
||||
(unless (ignore-errors (hitl-handle-message content :discord))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :discord :chat-id channel)
|
||||
:payload (list :sensor :user-input :text content))))))))))
|
||||
(error (c) (log-message "DISCORD POLL ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
|
||||
#+end_src
|
||||
135
org/channel-shell.org
Normal file
135
org/channel-shell.org
Normal file
@@ -0,0 +1,135 @@
|
||||
#+TITLE: SKILL: Shell Actuator (org-skill-shell-actuator.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:actuator:shell:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-shell.lisp
|
||||
|
||||
* Overview: The Physical Actuator
|
||||
|
||||
The Shell Actuator is the agent's hand in the physical world. Given a shell command, it executes it via ~bash -c~ and returns the output. This is how the agent installs packages, reads files, runs scripts, and interacts with any Unix tool.
|
||||
|
||||
Because shell execution is the highest-risk operation in the system, the Shell Actuator is protected by multiple safety layers:
|
||||
1. The Dispatcher's shell safety gate blocks destructive commands (~rm -rf /~, ~dd~, ~mkfs~)
|
||||
2. The Dispatcher's injection gate blocks backtick and ~$()~ patterns
|
||||
3. The Dispatcher's network exfil gate blocks connections to unwhitelisted hosts
|
||||
4. The actuator enforces a timeout (default 30s) so hanging commands don't freeze the agent
|
||||
5. The actuator caps output (default 100KB) so infinite output doesn't exhaust memory
|
||||
6. (v0.4.3) When ~bwrap~ (Bubblewrap) is available, commands execute inside a Linux namespace sandbox with network and IPC isolation
|
||||
|
||||
** Contract
|
||||
|
||||
1. (bwrap-available-p): returns T if ~bwrap~ is installed and usable, NIL otherwise.
|
||||
Cached at load time via ~which bwrap~.
|
||||
2. (bwrap-wrap-command cmd timeout memex-dir): returns a command list suitable for
|
||||
~uiop:run-program~ — wraps ~cmd~ in a ~bwrap~ sandbox with ~--unshare-net~,
|
||||
~--unshare-ipc~, ~--ro-bind~ for system dirs, and ~--bind~ for the memex and /tmp.
|
||||
3. (actuator-shell-execute action context): when ~bwrap~ is available, wraps the
|
||||
command through the sandbox. When ~bwrap~ is unavailable, falls back to the
|
||||
existing ~timeout bash -c~ behavior.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Shell Execution (actuator-shell-execute)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *bwrap-available* nil
|
||||
"Set to T at load time if the bwrap binary is found in PATH.")
|
||||
|
||||
(defvar *bwrap-base-args*
|
||||
'("--ro-bind" "/usr" "/usr"
|
||||
"--ro-bind" "/lib" "/lib"
|
||||
"--ro-bind" "/bin" "/bin"
|
||||
"--ro-bind" "/etc" "/etc"
|
||||
"--bind" "/tmp" "/tmp"
|
||||
"--unshare-net"
|
||||
"--unshare-ipc")
|
||||
"Base bwrap arguments for the sandbox. --bind ~/memex ~/memex is added dynamically.")
|
||||
|
||||
(defun bwrap-available-p ()
|
||||
"Returns T if bwrap (bubblewrap) is installed and usable."
|
||||
*bwrap-available*)
|
||||
|
||||
(defun bwrap-wrap-command (cmd timeout memex-dir)
|
||||
"Wrap CMD in a bwrap sandbox with network and IPC isolation.
|
||||
Returns a list suitable for uiop:run-program."
|
||||
`("bwrap"
|
||||
,@*bwrap-base-args*
|
||||
"--bind" ,memex-dir ,memex-dir
|
||||
"timeout" ,(format nil "~a" timeout)
|
||||
"bash" "-c" ,cmd))
|
||||
|
||||
;; Initialize at load time
|
||||
(setf *bwrap-available*
|
||||
(= 0 (nth-value 2 (uiop:run-program '("which" "bwrap") :output nil :error-output nil :ignore-error-status t))))
|
||||
|
||||
(defun actuator-shell-execute (action context)
|
||||
"Executes a shell command via the OS timeout binary with output limit.
|
||||
When bwrap is available, wraps the command in a Linux namespace sandbox."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :cmd))
|
||||
(timeout-sym (find-symbol "*DISPATCHER-SHELL-TIMEOUT*" :passepartout))
|
||||
(timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30)))
|
||||
(max-sym (find-symbol "*DISPATCHER-SHELL-MAX-OUTPUT*" :passepartout))
|
||||
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000)))
|
||||
(memex-dir (or (uiop:getenv "MEMEX_DIR") (namestring (merge-pathnames "memex/" (user-homedir-pathname))))))
|
||||
(log-message "ACT [Shell]: ~a (timeout: ~as)~@[ bwrap: enabled~]" cmd timeout (and *bwrap-available* " (bwrap)"))
|
||||
(let ((cmdline (if *bwrap-available*
|
||||
(bwrap-wrap-command cmd timeout memex-dir)
|
||||
(list "timeout" (format nil "~a" timeout) "bash" "-c" cmd))))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program cmdline
|
||||
:output :string :error-output :string
|
||||
:ignore-error-status t)
|
||||
(cond
|
||||
((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout))
|
||||
((> (length out) max-output)
|
||||
(format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output))
|
||||
((= code 0) out)
|
||||
(t (format nil "ERROR [~a]: ~a" code err)))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(register-actuator :shell #'actuator-shell-execute)
|
||||
|
||||
(defskill :passepartout-channel-shell
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-shell-actuator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:shell-actuator-suite))
|
||||
|
||||
(in-package :passepartout-shell-actuator-tests)
|
||||
|
||||
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
|
||||
(in-suite shell-actuator-suite)
|
||||
|
||||
(test test-bwrap-wrap-command
|
||||
"Contract 2: bwrap-wrap-command returns properly formatted command list."
|
||||
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
|
||||
(is (member "bwrap" cmdline :test #'string=))
|
||||
(is (member "--unshare-net" cmdline :test #'string=))
|
||||
(is (member "--unshare-ipc" cmdline :test #'string=))
|
||||
(is (member "echo hello" cmdline :test #'string=))))
|
||||
|
||||
(test test-bwrap-available-p-returns-boolean
|
||||
"Contract 1: bwrap-available-p returns T or NIL."
|
||||
(let ((avail (passepartout::bwrap-available-p)))
|
||||
(is (typep avail 'boolean))))
|
||||
|
||||
(test test-actuator-shell-execute-echo
|
||||
"Contract 3: actuator-shell-execute runs echo and returns output."
|
||||
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
|
||||
(result (passepartout::actuator-shell-execute action nil)))
|
||||
(is (stringp result))
|
||||
(is (search "hello" result :test #'char-equal))))
|
||||
#+end_src
|
||||
82
org/channel-signal.org
Normal file
82
org/channel-signal.org
Normal file
@@ -0,0 +1,82 @@
|
||||
#+TITLE: Channel Signal (channel-signal.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :channel:signal:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-signal.lisp
|
||||
|
||||
* Channel Signal
|
||||
|
||||
Extracted from gateway-messaging in v0.5.0. Isolated platform — Signal-specific poll and send logic.
|
||||
|
||||
* Overview
|
||||
|
||||
The Signal channel provides bidirectional communication via the ~signal-cli~ CLI tool.
|
||||
Messages received from Signal contacts are injected into the cognitive pipeline
|
||||
as ~:user-input~ signals with ~:source :signal~. Outbound messages route through
|
||||
the actuator registry when the pipeline targets ~:signal~.
|
||||
|
||||
The channel uses two functions: ~signal-poll~ (inbound sensor) and ~signal-send~
|
||||
(outbound actuator). Both retrieve the Signal account identifier from the
|
||||
credentials vault. HITL commands (~/approve~, ~/deny~) are intercepted before
|
||||
injection so approval flows work identically across all channels.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (signal-get-account): returns the Signal phone number from the vault
|
||||
(via ~vault-get-secret :signal~), or nil if not configured.
|
||||
2. (signal-poll): queries ~signal-cli receive --json~ for new messages,
|
||||
injects each non-system message as a ~:user-input~ stimulus with
|
||||
~:source :signal~. Handles JSON parse failures and network errors
|
||||
gracefully (logs and continues). HITL commands are intercepted before
|
||||
injection.
|
||||
3. (signal-send action context): sends a message via ~signal-cli send~.
|
||||
Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send
|
||||
failures without crashing the pipeline.
|
||||
|
||||
* Implementation
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(defun signal-get-account ()
|
||||
(vault-get-secret :signal))
|
||||
|
||||
(defun signal-poll ()
|
||||
"Polls Signal for new messages and injects them into the harness."
|
||||
(let ((account (signal-get-account)))
|
||||
(when account
|
||||
(handler-case
|
||||
(let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json")
|
||||
:output :string :error-output :string :ignore-error-status t))
|
||||
(lines (cl-ppcre:split "\\\\n" output)))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0))
|
||||
(let* ((json (ignore-errors (cl-json:decode-json-from-string line)))
|
||||
(envelope (cdr (assoc :envelope json)))
|
||||
(source (cdr (assoc :source envelope)))
|
||||
(data-message (cdr (assoc :data-message envelope)))
|
||||
(text (cdr (assoc :message data-message))))
|
||||
(when (and source text)
|
||||
(log-message "SIGNAL: Received message from ~a" source)
|
||||
(unless (ignore-errors (hitl-handle-message text :signal))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text)))))))))
|
||||
(error (c) (log-message "SIGNAL POLL ERROR: ~a" c))))))
|
||||
|
||||
(defun signal-send (action context)
|
||||
"Sends a message via Signal."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(handler-case
|
||||
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
|
||||
:output :string :error-output :string)
|
||||
(error (c) (log-message "SIGNAL ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
|
||||
#+end_src
|
||||
86
org/channel-slack.org
Normal file
86
org/channel-slack.org
Normal file
@@ -0,0 +1,86 @@
|
||||
#+TITLE: Channel Slack (channel-slack.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :channel:slack:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-slack.lisp
|
||||
|
||||
* Channel Slack
|
||||
|
||||
Extracted from gateway-messaging in v0.5.0. Isolated platform — Slack-specific poll and send logic.
|
||||
|
||||
* Overview
|
||||
|
||||
The Slack channel provides bidirectional communication via the Slack Web API
|
||||
(chat.postMessage for outbound, conversations.history for inbound polling).
|
||||
Messages from Slack channels are injected into the cognitive pipeline as
|
||||
~:user-input~ signals with ~:source :slack~. Outbound messages route through
|
||||
the actuator registry when the pipeline targets ~:slack~.
|
||||
|
||||
The channel uses two functions: ~slack-poll~ (inbound sensor) and ~slack-send~
|
||||
(outbound actuator). Both retrieve the bot token from the credentials vault.
|
||||
HITL commands are intercepted before injection so approval flows work identically
|
||||
across all channels.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (slack-get-token): returns the Slack bot token from the vault
|
||||
(via ~vault-get-secret :slack~), or nil if not configured.
|
||||
2. (slack-poll): polls configured channels via conversations.history,
|
||||
injects each non-bot message as a ~:user-input~ stimulus with
|
||||
~:source :slack~. Handles API errors gracefully. HITL commands are
|
||||
intercepted before injection.
|
||||
3. (slack-send action context): sends a message via chat.postMessage.
|
||||
Extracts ~:channel-id~ and ~:text~ from the action plist. Uses Bearer
|
||||
token authentication. Logs send failures without crashing the pipeline.
|
||||
|
||||
* Implementation
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(defun slack-get-token ()
|
||||
(vault-get-secret :slack))
|
||||
|
||||
(defun slack-send (action context)
|
||||
"Sends a message via Slack Web API."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(channel (or (getf meta :channel-id) (getf payload :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (slack-get-token)))
|
||||
(when (and token channel text)
|
||||
(handler-case
|
||||
(dex:post "https://slack.com/api/chat.postMessage"
|
||||
:headers `(("Authorization" . ,(format nil "Bearer ~a" token))
|
||||
("Content-Type" . "application/json; charset=utf-8"))
|
||||
:content (cl-json:encode-json-to-string
|
||||
`((channel . ,channel) (text . ,text))))
|
||||
(error (c) (log-message "SLACK ERROR: ~a" c))))))
|
||||
|
||||
(defun slack-poll ()
|
||||
"Polls Slack for new messages via conversations.history."
|
||||
(let* ((token (slack-get-token)))
|
||||
(when token
|
||||
(dolist (channel '("general")) ;; configured channel IDs
|
||||
(handler-case
|
||||
(let* ((url (format nil "https://slack.com/api/conversations.history?channel=~a&limit=5" channel))
|
||||
(response (dex:get url :headers
|
||||
`(("Authorization" . ,(format nil "Bearer ~a" token))))))
|
||||
(let* ((json (ignore-errors (cl-json:decode-json-from-string response)))
|
||||
(ok (cdr (assoc :ok json)))
|
||||
(messages (cdr (assoc :messages json))))
|
||||
(when (and ok messages (listp messages))
|
||||
(dolist (msg messages)
|
||||
(let* ((text (cdr (assoc :text msg)))
|
||||
(user (cdr (assoc :user msg)))
|
||||
(ts (cdr (assoc :ts msg))))
|
||||
(when (and text user (not (string= user "USLACKBOT")))
|
||||
(unless (ignore-errors (hitl-handle-message text :slack))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :slack :chat-id channel)
|
||||
:payload (list :sensor :user-input :text text))))))))))
|
||||
(error (c) (log-message "SLACK POLL ERROR: ~a" c)))))))
|
||||
#+end_src
|
||||
|
||||
|
||||
#+end_src
|
||||
90
org/channel-telegram.org
Normal file
90
org/channel-telegram.org
Normal file
@@ -0,0 +1,90 @@
|
||||
#+TITLE: Channel Telegram (channel-telegram.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :channel:telegram:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-telegram.lisp
|
||||
|
||||
* Channel Telegram
|
||||
|
||||
Extracted from gateway-messaging in v0.5.0. Isolated platform — Telegram-specific poll and send logic.
|
||||
|
||||
* Overview
|
||||
|
||||
The Telegram channel provides bidirectional communication via the Telegram Bot
|
||||
API. Messages from Telegram chats are injected into the cognitive pipeline as
|
||||
~:user-input~ signals with ~:source :telegram~. Outbound messages route through
|
||||
the actuator registry when the pipeline targets ~:telegram~.
|
||||
|
||||
The channel uses two functions: ~telegram-poll~ (inbound sensor, getUpdates
|
||||
with offset tracking) and ~telegram-send~ (outbound actuator, sendMessage).
|
||||
Both retrieve the bot token from the credentials vault. The polling offset
|
||||
(~:last-update-id~ in ~*gateway-configs*~) prevents duplicate processing across
|
||||
poll cycles. HITL commands are intercepted before injection so approval flows
|
||||
work identically across all channels.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (telegram-get-token): returns the Telegram bot token from the vault
|
||||
(via ~vault-get-secret :telegram~), or nil if not configured.
|
||||
2. (telegram-poll): polls getUpdates with offset tracking (prevents
|
||||
duplicate processing), injects each message as a ~:user-input~ stimulus
|
||||
with ~:source :telegram~. Updates ~:last-update-id~ per cycle. Handles
|
||||
API and JSON parse errors gracefully. HITL commands are intercepted
|
||||
before injection.
|
||||
3. (telegram-send action context): sends a message via sendMessage.
|
||||
Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send
|
||||
failures without crashing the pipeline.
|
||||
|
||||
* Implementation
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
|
||||
(defun telegram-poll ()
|
||||
"Polls Telegram for new messages and injects them into the harness."
|
||||
(let* ((token (telegram-get-token)))
|
||||
(when token
|
||||
(let* ((last-id (getf (gethash "telegram" *gateway-configs*) :last-update-id 0))
|
||||
(url (format nil "https://api.telegram.org/bot~a/getUpdates?offset=~a"
|
||||
token (1+ last-id))))
|
||||
(handler-case
|
||||
(let* ((response (dex:get url))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(updates (cdr (assoc :result json))))
|
||||
(dolist (update updates)
|
||||
(let* ((update-id (cdr (assoc :update--id update)))
|
||||
(message (cdr (assoc :message update)))
|
||||
(chat (cdr (assoc :chat message)))
|
||||
(chat-id (cdr (assoc :id chat)))
|
||||
(text (cdr (assoc :text message))))
|
||||
(setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id)
|
||||
(when (and text chat-id)
|
||||
(log-message "TELEGRAM: Received message from ~a" chat-id)
|
||||
(unless (ignore-errors (hitl-handle-message text :telegram))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c)))))))
|
||||
|
||||
(defun telegram-send (action context)
|
||||
"Sends a message via Telegram."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
:headers '(("Content-Type" . "application/json"))
|
||||
:content (cl-json:encode-json-to-string
|
||||
`((chat_id . ,chat-id) (text . ,text)))))
|
||||
(error (c) (log-message "TELEGRAM ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
|
||||
#+end_src
|
||||
1390
org/channel-tui-main.org
Normal file
1390
org/channel-tui-main.org
Normal file
File diff suppressed because it is too large
Load Diff
365
org/channel-tui-state.org
Normal file
365
org/channel-tui-state.org
Normal file
@@ -0,0 +1,365 @@
|
||||
#+TITLE: Passepartout TUI — Model
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
|
||||
|
||||
* Model
|
||||
|
||||
The TUI state is a single plist accessed via ~st~ / ~(setf st)~.
|
||||
All state mutation flows through event handlers in the controller.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (init-state): returns a fresh state plist with ~:msgs~ list,
|
||||
~:input~ buffer, ~:dirty~ flag, ~:busy~ flag, and ~:connection~ status.
|
||||
2. (add-msg role content &key gate-trace): appends a message object
|
||||
to the ~:messages~ vector (v0.3.3), tagged with timestamp, role,
|
||||
and optional gate-trace from the daemon (v0.4.0).
|
||||
3. (queue-event ev): thread-safely enqueues an event for the
|
||||
reader loop. (drain-queue) returns and clears the queue.
|
||||
|
||||
** Package + State
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
|
||||
(defpackage :passepartout.channel-tui
|
||||
(:use :cl :passepartout :usocket :bordeaux-threads)
|
||||
(:export :tui-main :st :add-msg :now
|
||||
:queue-event :drain-queue :init-state
|
||||
:view-status :view-chat :view-input :redraw
|
||||
:input-panel-top
|
||||
:on-key :process-key-event :input-text :on-daemon-msg :send-daemon
|
||||
:connect-daemon :disconnect-daemon
|
||||
:*theme* :theme-color :theme-switch))
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defvar *state* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
||||
|
||||
(defvar *theme* (cl-tty.theme:make-theme)
|
||||
"The active theme instance. Populated by cl-tty.theme:load-preset.
|
||||
|
||||
Semantic keys (all presets define these):
|
||||
:user-fg, :user-bg, :user-border, :agent-border, :agent-header, :agent-fg,
|
||||
:system, :input-prompt, :input-fg, :hint, :status-bg, :status-fg,
|
||||
:bg, :bg-panel, :bg-element, :bg-input, :text-muted,
|
||||
:dot-connected, :dot-disconnected, :error,
|
||||
:tool-running, :tool-done, :tool-error,
|
||||
:thinking-bg, :symbolic-border, :separator, :accent, :dim.")
|
||||
|
||||
(cl-tty.theme:define-preset :amber
|
||||
:dark (:user-fg "#fab283" :user-bg "#1e1e1e" :user-border "#fab283"
|
||||
:agent-border "#c0a080" :agent-header "#d4956a" :agent-fg "#e8e8e8"
|
||||
:system "#808080"
|
||||
:input-prompt "#fab283" :input-fg "#e8e8e8" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#e8e8e8"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7fd88f" :dot-disconnected "#e06c75"
|
||||
:error "#e06c75"
|
||||
:tool-running "#fab283" :tool-done "#7fd88f" :tool-error "#e06c75"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#fab283" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :gold
|
||||
:dark (:user-fg "#ffd700" :user-bg "#1e1e1e" :user-border "#ffd700"
|
||||
:agent-border "#c0a080" :agent-header "#d4a574" :agent-fg "#e8e8e8"
|
||||
:system "#808080"
|
||||
:input-prompt "#ffd700" :input-fg "#e8e8e8" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#ffd700"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7fd88f" :dot-disconnected "#e06c75"
|
||||
:error "#e06c75"
|
||||
:tool-running "#ffd700" :tool-done "#7fd88f" :tool-error "#e06c75"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#ffd700" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :terracotta
|
||||
:dark (:user-fg "#e87a5d" :user-bg "#1e1e1e" :user-border "#e87a5d"
|
||||
:agent-border "#c0a080" :agent-header "#d4956a" :agent-fg "#e0c8b0"
|
||||
:system "#808080"
|
||||
:input-prompt "#e87a5d" :input-fg "#e0c8b0" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#d4956a"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#6cb85c" :dot-disconnected "#d94a3a"
|
||||
:error "#d94a3a"
|
||||
:tool-running "#e87a5d" :tool-done "#6cb85c" :tool-error "#d94a3a"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#e87a5d" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :sepia
|
||||
:dark (:user-fg "#c4a882" :user-bg "#1e1e1e" :user-border "#c4a882"
|
||||
:agent-border "#c0a080" :agent-header "#b89870" :agent-fg "#d4c4a8"
|
||||
:system "#808080"
|
||||
:input-prompt "#c4a882" :input-fg "#d4c4a8" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#b89870"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7aac5c" :dot-disconnected "#c84a3a"
|
||||
:error "#c84a3a"
|
||||
:tool-running "#c4a882" :tool-done "#7aac5c" :tool-error "#c84a3a"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#c4a882" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :nord-warm
|
||||
:dark (:user-fg "#d4a574" :user-bg "#1e1e1e" :user-border "#d4a574"
|
||||
:agent-border "#c0a080" :agent-header "#c49870" :agent-fg "#e0d0c0"
|
||||
:system "#808080"
|
||||
:input-prompt "#d08770" :input-fg "#e0d0c0" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#c8a080"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7cb860" :dot-disconnected "#d06050"
|
||||
:error "#d06050"
|
||||
:tool-running "#d08770" :tool-done "#7cb860" :tool-error "#d06050"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#d4a574" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :monokai-warm
|
||||
:dark (:user-fg "#e6b87d" :user-bg "#1e1e1e" :user-border "#e6b87d"
|
||||
:agent-border "#c0a080" :agent-header "#d4a06a" :agent-fg "#d8c8b0"
|
||||
:system "#808080"
|
||||
:input-prompt "#e6b87d" :input-fg "#d8c8b0" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#cc9966"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7ab85c" :dot-disconnected "#d94a3a"
|
||||
:error "#d94a3a"
|
||||
:tool-running "#e6b87d" :tool-done "#7ab85c" :tool-error "#d94a3a"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#e6b87d" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :gruvbox-warm
|
||||
:dark (:user-fg "#d8a657" :user-bg "#1e1e1e" :user-border "#d8a657"
|
||||
:agent-border "#c0a080" :agent-header "#c8a070" :agent-fg "#e0c8a8"
|
||||
:system "#808080"
|
||||
:input-prompt "#d8a657" :input-fg "#e0c8a8" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#c8a070"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#7ab85c" :dot-disconnected "#d94a3a"
|
||||
:error "#d94a3a"
|
||||
:tool-running "#d8a657" :tool-done "#7ab85c" :tool-error "#d94a3a"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3c3c3c" :accent "#d8a657" :dim "#606060")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :light-amber
|
||||
:dark (:user-fg "#d4a574" :user-bg "#f5f0eb" :user-border "#c4956a"
|
||||
:agent-border "#c0a090" :agent-header "#b88050" :agent-fg "#3a3a3a"
|
||||
:system "#606060"
|
||||
:input-prompt "#c4956a" :input-fg "#3a3a3a" :hint "#a0a0a0"
|
||||
:status-bg "#e8e0d8" :status-fg "#5a5a5a"
|
||||
:bg "#f5f0eb" :bg-panel "#e8e0d8" :bg-element "#f0ebe5"
|
||||
:bg-input "#ffffff" :text-muted "#909090"
|
||||
:dot-connected "#6cb85c" :dot-disconnected "#c84a3a"
|
||||
:error "#c84a3a"
|
||||
:tool-running "#c4956a" :tool-done "#6cb85c" :tool-error "#c84a3a"
|
||||
:thinking-bg "#e8e0d8" :symbolic-border "#a09080"
|
||||
:separator "#d0c8c0" :accent "#b88050" :dim "#a0a0a0")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :catppuccin
|
||||
:dark (:user-fg "#fab387" :user-bg "#1e1e2e" :user-border "#fab387"
|
||||
:agent-border "#a6adc8" :agent-header "#cba6f7" :agent-fg "#cdd6f4"
|
||||
:system "#808080"
|
||||
:input-prompt "#fab387" :input-fg "#cdd6f4" :hint "#6c7086"
|
||||
:status-bg "#181825" :status-fg "#bac2de"
|
||||
:bg "#11111b" :bg-panel "#181825" :bg-element "#1e1e2e"
|
||||
:bg-input "#2e2e2e" :text-muted "#6c7086"
|
||||
:dot-connected "#a6e3a1" :dot-disconnected "#f38ba8"
|
||||
:error "#f38ba8"
|
||||
:tool-running "#fab387" :tool-done "#a6e3a1" :tool-error "#f38ba8"
|
||||
:thinking-bg "#363a4f" :symbolic-border "#6c7086"
|
||||
:separator "#313244" :accent "#fab387" :dim "#585b70")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :tokyonight
|
||||
:dark (:user-fg "#ff9e64" :user-bg "#1a1b26" :user-border "#ff9e64"
|
||||
:agent-border "#7982a8" :agent-header "#7aa2f7" :agent-fg "#a9b1d6"
|
||||
:system "#808080"
|
||||
:input-prompt "#ff9e64" :input-fg "#a9b1d6" :hint "#565f89"
|
||||
:status-bg "#16161e" :status-fg "#9aa5ce"
|
||||
:bg "#0f0f18" :bg-panel "#16161e" :bg-element "#1a1b26"
|
||||
:bg-input "#2e2e2e" :text-muted "#565f89"
|
||||
:dot-connected "#9ece6a" :dot-disconnected "#db4b4b"
|
||||
:error "#db4b4b"
|
||||
:tool-running "#ff9e64" :tool-done "#9ece6a" :tool-error "#db4b4b"
|
||||
:thinking-bg "#363b54" :symbolic-border "#565f89"
|
||||
:separator "#292e42" :accent "#ff9e64" :dim "#444b6a")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :dracula
|
||||
:dark (:user-fg "#ff9580" :user-bg "#1e1f2b" :user-border "#ff9580"
|
||||
:agent-border "#c0c0e0" :agent-header "#bd93f9" :agent-fg "#f8f8f2"
|
||||
:system "#808080"
|
||||
:input-prompt "#ff9580" :input-fg "#f8f8f2" :hint "#6272a4"
|
||||
:status-bg "#191a24" :status-fg "#e0e0e0"
|
||||
:bg "#0f101a" :bg-panel "#191a24" :bg-element "#1e1f2b"
|
||||
:bg-input "#2e2e2e" :text-muted "#6272a4"
|
||||
:dot-connected "#50fa7b" :dot-disconnected "#ff5555"
|
||||
:error "#ff5555"
|
||||
:tool-running "#ff9580" :tool-done "#50fa7b" :tool-error "#ff5555"
|
||||
:thinking-bg "#3a3b50" :symbolic-border "#6272a4"
|
||||
:separator "#34354a" :accent "#ff9580" :dim "#5a5b7a")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :gemini
|
||||
:dark (:user-fg "#87afff" :user-bg "#1a1a1a" :user-border "#87afff"
|
||||
:agent-border "#d0d0d0" :agent-header "#d7afff" :agent-fg "#ffffff"
|
||||
:system "#808080"
|
||||
:input-prompt "#87afff" :input-fg "#ffffff" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#afafaf"
|
||||
:bg "#000000" :bg-panel "#141414" :bg-element "#1a1a1a"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#d7ffd7" :dot-disconnected "#ff87af"
|
||||
:error "#ff87af"
|
||||
:tool-running "#87afff" :tool-done "#d7ffd7" :tool-error "#ff87af"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#707070"
|
||||
:separator "#3a3a3a" :accent "#87afff" :dim "#5f5f5f")
|
||||
:light nil)
|
||||
(cl-tty.theme:define-preset :mono
|
||||
:dark (:user-fg "#e0e0e0" :user-bg "#1a1a1a" :user-border "#808080"
|
||||
:agent-border "#a0a0a0" :agent-header "#c0c0c0" :agent-fg "#d0d0d0"
|
||||
:system "#808080"
|
||||
:input-prompt "#ffffff" :input-fg "#d0d0d0" :hint "#606060"
|
||||
:status-bg "#141414" :status-fg "#b0b0b0"
|
||||
:bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1a1a1a"
|
||||
:bg-input "#2e2e2e" :text-muted "#808080"
|
||||
:dot-connected "#a0a0a0" :dot-disconnected "#808080"
|
||||
:error "#808080"
|
||||
:tool-running "#e0e0e0" :tool-done "#a0a0a0" :tool-error "#808080"
|
||||
:thinking-bg "#3a3a3a" :symbolic-border "#808080"
|
||||
:separator "#303030" :accent "#ffffff" :dim "#505050")
|
||||
:light nil)
|
||||
|
||||
;; Load default theme at startup
|
||||
(cl-tty.theme:load-preset *theme* :amber)
|
||||
|
||||
(defun theme-save ()
|
||||
"Persist current theme to disk."
|
||||
(let ((path (merge-pathnames ".cache/passepartout/theme.lisp"
|
||||
(user-homedir-pathname))))
|
||||
(ensure-directories-exist path)
|
||||
(cl-tty.theme:save-theme *theme* path)))
|
||||
|
||||
(defun theme-load ()
|
||||
"Load persisted theme from disk. Called at startup."
|
||||
(let ((path (merge-pathnames ".cache/passepartout/theme.lisp"
|
||||
(user-homedir-pathname))))
|
||||
(unless (cl-tty.theme:load-theme *theme* path)
|
||||
(cl-tty.theme:load-preset *theme* :amber))))
|
||||
|
||||
(defun theme-switch (name)
|
||||
"Switch to a named theme preset. Returns the preset name or nil if not found."
|
||||
(let ((key (intern (string-upcase (string name)) :keyword)))
|
||||
(cl-tty.theme:load-preset *theme* key)
|
||||
(theme-save)
|
||||
(setf (st :dirty) (list t t t))
|
||||
key))
|
||||
|
||||
(defun theme-color (role)
|
||||
"Returns a hex color string for a semantic role via cl-tty.theme."
|
||||
(or (cl-tty.theme:theme-color *theme* role)
|
||||
"#FFFFFF"))
|
||||
|
||||
(defun st (key) (getf *state* key))
|
||||
(defun (setf st) (val key) (setf (getf *state* key) val))
|
||||
|
||||
(defun init-state ()
|
||||
(setf *state*
|
||||
(list :running t :mode :chat :connected nil :stream nil
|
||||
:input-history nil :input-hpos 0
|
||||
:text-input (cl-tty.input:make-text-input
|
||||
:on-submit #'handle-submit
|
||||
:on-cancel #'handle-cancel
|
||||
:on-tab #'handle-tab
|
||||
:on-history #'handle-history)
|
||||
:messages (make-array 16 :adjustable t :fill-pointer 0)
|
||||
:scroll-offset 0 :busy nil
|
||||
:pending-ctrl-x nil
|
||||
:scroll-at-bottom t :scroll-notify nil
|
||||
:streaming-text nil :url-buffer nil ; v0.7.1
|
||||
:collapsed-gates nil ; v0.7.2
|
||||
:search-mode nil :search-query "" ; v0.7.2
|
||||
:search-matches nil :search-match-idx 0
|
||||
:sidebar-mode :auto ; v0.8.0: :auto/:visible/:hidden
|
||||
:sidebar-width 42 ; v0.8.0
|
||||
:expand-tool-calls nil ; v0.8.0
|
||||
:mcp-count 0 ; v0.8.0
|
||||
:kill-ring nil ; v0.9.0
|
||||
:dialog-stack nil ; v0.8.0
|
||||
:minibuffer-active nil ; v0.8.0
|
||||
:command-palette-active nil ; v0.8.0
|
||||
:command-palette-dialog nil ; v0.8.0
|
||||
:session-cost 0.0 ; v0.9.0
|
||||
:daemon-version nil ; filled by handshake
|
||||
:dirty (list nil nil nil))))
|
||||
#+END_SRC
|
||||
|
||||
** Helpers
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
|
||||
(defun now ()
|
||||
(multiple-value-bind (s m h) (get-decoded-time)
|
||||
(declare (ignore s))
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun add-msg (role content &key gate-trace panel)
|
||||
(vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace :panel panel) (st :messages))
|
||||
;; v0.7.0: notify when scrolled up and new msg arrives
|
||||
(unless (st :scroll-at-bottom)
|
||||
(setf (st :scroll-notify) t))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
#+END_SRC
|
||||
|
||||
** Slash Commands
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
|
||||
(defvar *slash-commands*
|
||||
'((:title "/eval <expr> — Evaluate Lisp" :value "/eval")
|
||||
(:title "/undo — Undo last operation" :value "/undo")
|
||||
(:title "/redo — Redo last operation" :value "/redo")
|
||||
(:title "/reconnect — Re-establish daemon" :value "/reconnect")
|
||||
(:title "/quit — Save history and exit" :value "/quit")
|
||||
(:title "/q — Quick quit" :value "/q")
|
||||
(:title "/why — Show last gate trace" :value "/why")
|
||||
(:title "/tags — List tag severities" :value "/tags")
|
||||
(:title "/audit <id> — Inspect memory" :value "/audit")
|
||||
(:title "/audit verify — Memory integrity" :value "/audit verify")
|
||||
(:title "/rewind <n> — Rewind to snapshot" :value "/rewind")
|
||||
(:title "/sessions — Show memory snapshots" :value "/sessions")
|
||||
(:title "/resume <n> — Resume from snapshot" :value "/resume")
|
||||
(:title "/theme [name] — Show/switch theme" :value "/theme")
|
||||
(:title "/context — Show context summary" :value "/context")
|
||||
(:title "/search <query> — Search messages" :value "/search")
|
||||
(:title "/help — Show commands" :value "/help")
|
||||
(:title "/help <topic> — Search manual" :value "/help "))
|
||||
"Slash commands for minibuffer select-dialog.")
|
||||
|
||||
(defvar *daemon-commands*
|
||||
'((:title "Status — Daemon health info" :value (:action :status))
|
||||
(:title "Stats — Daemon statistics" :value (:action :stats))
|
||||
(:title "Ping — Daemon reachability" :value (:action :ping))
|
||||
(:title "Memory Snapshot — Capture state" :value (:action :memory-snapshot))
|
||||
(:title "Memory Rebuild — Rebuild indices" :value (:action :memory-rebuild))
|
||||
(:title "Memory Compact — Optimize storage" :value (:action :memory-compact))
|
||||
(:title "Reload Config — Reload configuration" :value (:action :reload-config))
|
||||
(:title "Reload Identity — Reload identity file" :value (:action :reload-identity))
|
||||
(:title "List Skills — Available skills" :value (:action :list-skills))
|
||||
(:title "Help — Show daemon help" :value (:action :help)))
|
||||
"Daemon commands for the command palette (Ctrl+P).")
|
||||
|
||||
(defun all-commands ()
|
||||
"Merge slash commands, daemon commands, and menu entries into one unified list."
|
||||
(append *menu-entries* *slash-commands* *daemon-commands*))
|
||||
|
||||
(defvar *menu-entries*
|
||||
'((:title "/config — LLM providers, cascade, network, folders, identity"
|
||||
:value :config-menu
|
||||
:action passepartout.channel-tui::show-config-main-menu))
|
||||
"Special menu entries with actions (open submenus).")
|
||||
#+END_SRC
|
||||
|
||||
** Event Queue
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
|
||||
(defun queue-event (ev)
|
||||
(bt:with-lock-held (*event-lock*) (push ev *event-queue*)))
|
||||
|
||||
(defun drain-queue ()
|
||||
(bt:with-lock-held (*event-lock*)
|
||||
(let ((evs (nreverse *event-queue*)))
|
||||
(setf *event-queue* nil) evs)))
|
||||
#+END_SRC
|
||||
517
org/channel-tui-view.org
Normal file
517
org/channel-tui-view.org
Normal file
@@ -0,0 +1,517 @@
|
||||
#+TITLE: Passepartout TUI — View
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
|
||||
* View
|
||||
|
||||
|Pure render functions. Each takes the cl-tty backend and current state.
|
||||
|State is read via ~(st :key)~ — no mutation here.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (view-status fb w h): no-op. Status bar is a clean black line.
|
||||
2. (view-chat fb w h): renders scrolled chat messages. User messages
|
||||
get amber left border (│), agent messages no border, streaming
|
||||
agent gets grey left border. Gate traces/tool calls use ╎ prefix.
|
||||
3. (view-input fb w h): renders expanding light grey input box,
|
||||
multi-line word-wrapped prompt, hint bar at h-2. Text and cursor
|
||||
rendered by cl-tty.input text-input's render method.
|
||||
4. (view-sidebar fb w h): renders sidebar panels using ~sidebar-lines~.
|
||||
5. (sidebar-lines): builds a flat list of (text . color-key) pairs for
|
||||
the sidebar: gate trace, rules, cost, files, version.
|
||||
6. (msg->pairs msg index bordered-w unbordered-w is-search): converts
|
||||
a message to renderable ~(border border-color text text-color &optional bg)~
|
||||
lines. Handles markdown, gate trace, tool calls, search highlight.
|
||||
7. (render-pair fb hpad y pair): draws one message line pair.
|
||||
8. (redraw fb w h): wraps view-status/chat/input in begin-sync/end-sync,
|
||||
dispatches per dirty flags, fills global :bg first.
|
||||
9. ~cl-tty.box:char-width~ for terminal column width.
|
||||
ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0.
|
||||
Tab = 8. Used by cl-tty.box:word-wrap for accurate line counting.
|
||||
10. (sidebar-visible-p w): returns T if sidebar should show given width W
|
||||
and current :sidebar-mode (:auto >120, :visible always, :hidden never).
|
||||
|
||||
** Status Bar
|
||||
|
||||
The status bar, as of v0.4.0, renders Passepartout's three differentiator
|
||||
visualizations — data only available because of the deterministic gate
|
||||
architecture:
|
||||
|
||||
- *Rule counter* (~Rules:N~): the number of pending HITL actions from the
|
||||
Dispatcher's ~*hitl-pending*~ hash table. The user watches this tick up
|
||||
as they teach the agent their preferences through approve/deny decisions.
|
||||
- *Focus map* (~[Focus: <id>]~): the foveal focus from the daemon's signal
|
||||
context. Shows the user what the agent is currently looking at.
|
||||
- *Gate trace* (not rendered in status bar — attached to individual
|
||||
messages via ~:gate-trace~ field for future collapsible rendering per
|
||||
message).
|
||||
|
||||
All three enrichments cost 0 LLM tokens — they are daemon-state queries
|
||||
that the TUI actuator attaches to the response plist before transmission.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun sidebar-visible-p (w)
|
||||
"Compute whether sidebar should be shown given terminal width W
|
||||
and current sidebar mode (:auto/:visible/:hidden)."
|
||||
(let ((mode (st :sidebar-mode)))
|
||||
(or (eq mode :visible)
|
||||
(and (eq mode :auto) (> w 120)))))
|
||||
|
||||
(defun view-status (fb w h)
|
||||
(declare (ignore fb w h))
|
||||
;; Status bar is now a clean black line — blends with global :bg.
|
||||
;; No clock, no dot, no text. Everything clean.
|
||||
)
|
||||
|
||||
(defun input-panel-top (chat-w h)
|
||||
"Compute the top row of the input panel based on current input text."
|
||||
(let* ((hpad 2)
|
||||
(inner-w (- chat-w (* 2 hpad)))
|
||||
(prompt-w (- inner-w 2))
|
||||
(text (cl-tty.input:text-input-value (st :text-input)))
|
||||
(lines (cl-tty.box:word-wrap text prompt-w))
|
||||
(n-lines (max 1 (length lines)))
|
||||
(panel-rows (max 4 (+ n-lines 2))))
|
||||
(- h 4 panel-rows -1)))
|
||||
#+end_src
|
||||
|
||||
;; Build simple tab-like blocks
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun msg->pairs (msg index bordered-w unbordered-w is-search)
|
||||
"Convert a message to a list of (border-str border-color text-str text-color &optional bg) lines."
|
||||
(let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(cs (if is-search (cl-tty.markdown:search-highlight content (st :search-query)) content))
|
||||
(pairs nil)
|
||||
(think-bg (theme-color :thinking-bg))
|
||||
(sym-bdr (theme-color :symbolic-border))
|
||||
(agent-bdr (theme-color :agent-border))
|
||||
(user-bdr (theme-color :user-border))
|
||||
(user-fg (theme-color :user-fg))
|
||||
(agent-fg (theme-color :agent-fg))
|
||||
(system-fg (theme-color :system)))
|
||||
(case role
|
||||
(:user
|
||||
(dolist (l (cl-tty.box:word-wrap cs bordered-w))
|
||||
(push (list "│" user-bdr l user-fg) pairs)))
|
||||
(:agent
|
||||
(let* ((streaming (getf msg :streaming))
|
||||
(think-rect (if streaming think-bg nil))
|
||||
(bdr (if streaming nil agent-bdr))
|
||||
(bstr (if streaming nil "│"))
|
||||
(wrap-w (if streaming unbordered-w bordered-w))
|
||||
(nodes (cl-tty.markdown:parse-blocks cs))
|
||||
(raw-body (or (and nodes (cl-tty.markdown:render-md nodes)) (list "")))
|
||||
(body (mapcan (lambda (l) (cl-tty.box:word-wrap l wrap-w)) raw-body)))
|
||||
(dolist (l body)
|
||||
(push (list bstr bdr l agent-fg think-rect) pairs))))
|
||||
(t (dolist (l (cl-tty.box:word-wrap cs unbordered-w))
|
||||
(push (list nil nil l system-fg) pairs))))
|
||||
;; Gate trace
|
||||
(let ((gt (getf msg :gate-trace)))
|
||||
(when (and gt (eq role :agent))
|
||||
(if (member index (st :collapsed-gates))
|
||||
(push (list "│" sym-bdr (format nil "Gate trace: ~a gates" (length gt)) sym-bdr) pairs)
|
||||
(dolist (entry (passepartout::gate-trace-lines gt))
|
||||
(let ((ec (theme-color (getf (cdr entry) :fgcolor))))
|
||||
(dolist (l (cl-tty.box:word-wrap (car entry) bordered-w))
|
||||
(push (list "│" sym-bdr l ec) pairs)))))))
|
||||
;; Tool calls
|
||||
(let ((tc (getf msg :tool-calls)))
|
||||
(when tc
|
||||
(if (member index (st :collapsed-tools))
|
||||
(let* ((n (or (getf (first tc) :name) "tool"))
|
||||
(d (or (getf (first tc) :duration) 0.0)))
|
||||
(push (list "│" (theme-color :tool-done) (format nil "~a … ~,1fs" n d) (theme-color :tool-done)) pairs))
|
||||
(dolist (call tc)
|
||||
(let* ((name (or (getf call :name) "tool"))
|
||||
(dur (or (getf call :duration) 0.0))
|
||||
(st (getf call :status))
|
||||
(out (getf call :output))
|
||||
(bc (theme-color
|
||||
(cond ((eq st :running) :tool-running)
|
||||
((eq st :error) :tool-error)
|
||||
(t :tool-done))))
|
||||
(pfx (cond ((eq st :error) "✗") ((eq st :running) "●") (t "✓")))
|
||||
(ol (when out (cl-tty.box:word-wrap out bordered-w))))
|
||||
(push (list "│" bc (format nil "~a ~a ~,1fs" pfx name dur) bc) pairs)
|
||||
(dolist (l ol)
|
||||
(push (list "│" bc l bc) pairs)))))))
|
||||
(nreverse pairs)))
|
||||
|
||||
(defun render-pair (fb hpad y pair)
|
||||
"Draw a single (border-str border-color text-str text-color &optional bg) line."
|
||||
(destructuring-bind (bstr bcolor tstr tcolor &optional rect-bg) pair
|
||||
(when rect-bg
|
||||
(cl-tty.backend:draw-rect fb 0 y 1 1 :bg rect-bg))
|
||||
(let ((has-border (and bstr (> (length bstr) 0))))
|
||||
(when has-border
|
||||
(cl-tty.backend:draw-text fb hpad y bstr bcolor (theme-color :bg)))
|
||||
(cl-tty.backend:draw-text fb (+ hpad (if has-border 2 0)) y tstr tcolor (theme-color :bg)))))
|
||||
|
||||
(defun view-chat (fb w h)
|
||||
(let* ((w (or (and (numberp w) (> w 0) w) 80))
|
||||
(h (or (and (numberp h) (> h 0) h) 24))
|
||||
(hpad 2)
|
||||
(sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
|
||||
(chat-w (- w sidebar-w))
|
||||
(msgs (st :messages)) (total (length msgs))
|
||||
(panel-top (input-panel-top chat-w h))
|
||||
(max-lines (max 0 panel-top)) (is-search (st :search-mode))
|
||||
(bordered-w (- chat-w (* 2 hpad) 2))
|
||||
(unbordered-w (- chat-w (* 2 hpad)))
|
||||
(y 0))
|
||||
;; Search header
|
||||
(when is-search
|
||||
(let* ((matches (st :search-matches)) (idx (st :search-match-idx))
|
||||
(query (st :search-query))
|
||||
(hdr (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit"
|
||||
(length matches) query (1+ idx) (length matches))))
|
||||
(cl-tty.backend:draw-text fb hpad y hdr (theme-color :accent) nil)
|
||||
(incf y) (decf max-lines)))
|
||||
;; Build all message lines once
|
||||
(let* ((msg-lines (map 'vector
|
||||
(lambda (msg i) (msg->pairs msg i bordered-w unbordered-w is-search))
|
||||
msgs
|
||||
(make-array total :initial-contents (loop for i below total collect i))))
|
||||
(heights (map 'vector #'length msg-lines))
|
||||
(scroll-skip (st :scroll-offset))
|
||||
(i 0))
|
||||
;; Forward scan: skip messages scrolled past, then render visible ones
|
||||
(loop while (< i total)
|
||||
do (let ((hgt (aref heights i)))
|
||||
(if (> scroll-skip 0)
|
||||
(decf scroll-skip hgt)
|
||||
(let ((msg-y y))
|
||||
(dolist (pair (aref msg-lines i))
|
||||
(when (>= msg-y panel-top) (return))
|
||||
(render-pair fb hpad msg-y pair)
|
||||
(incf msg-y))
|
||||
(setf y (1+ msg-y)) ;; +1 spacer between messages
|
||||
(when (>= y panel-top) (return)))))
|
||||
(incf i)))))
|
||||
#+END_SRC
|
||||
|
||||
** Input Line
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(defun view-input (fb w h)
|
||||
(let* ((w (or (and (numberp w) (> w 0) w) 80))
|
||||
(h (or (and (numberp h) (> h 0) h) 24))
|
||||
(hpad 2)
|
||||
(sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
|
||||
(chat-w (- w sidebar-w))
|
||||
(inner-w (- chat-w (* 2 hpad)))
|
||||
(prompt-w (- inner-w 2))
|
||||
(input (st :text-input))
|
||||
(n-lines (max 1 (length (cl-tty.box:word-wrap (cl-tty.input:text-input-value input) prompt-w))))
|
||||
(panel-rows (max 4 (+ n-lines 2)))
|
||||
(panel-top (input-panel-top chat-w h))
|
||||
(bg-i (theme-color :bg-input))
|
||||
(hint-fg (theme-color :hint)))
|
||||
;; Fill input panel
|
||||
(cl-tty.backend:draw-rect fb hpad panel-top inner-w panel-rows :bg bg-i)
|
||||
;; Speaker lines for all input rows
|
||||
(dotimes (r panel-rows)
|
||||
(cl-tty.backend:draw-text fb hpad (+ panel-top r) "│" (theme-color :input-prompt) nil))
|
||||
;; Render text-input widget (word-wrap + cursor)
|
||||
(let ((ln (cl-tty.layout:make-layout-node)))
|
||||
(setf (cl-tty.layout:layout-node-x ln) (+ hpad 2)
|
||||
(cl-tty.layout:layout-node-y ln) (1+ panel-top)
|
||||
(cl-tty.layout:layout-node-width ln) prompt-w)
|
||||
(setf (cl-tty.input:text-input-layout-node input) ln)
|
||||
(cl-tty.box:render input fb))
|
||||
;; Hint bar at h-2
|
||||
(let* ((focal (or (st :foveal-id) "-"))
|
||||
(focal-str (format nil "F:~a" focal))
|
||||
(mcp-str (format nil "MCP:~d" (or (st :mcp-count) 0)))
|
||||
(left-str (format nil "~a ~a" focal-str mcp-str))
|
||||
(msg-count (max 1 (length (st :messages))))
|
||||
(ctx-est (* msg-count 60))
|
||||
(ctx-limit 8192)
|
||||
(ctx-pct (min 100 (floor (* 100 ctx-est) ctx-limit)))
|
||||
(ctx-tok (if (< ctx-est 1000)
|
||||
(format nil "~d" ctx-est)
|
||||
(format nil "~dK" (floor ctx-est 1000))))
|
||||
(ctx-str (format nil "~a (~d%%)" ctx-tok ctx-pct))
|
||||
(hint-str "ctrl+p | /help")
|
||||
(ctx-fg (cond ((< ctx-pct 50) (theme-color :tool-done))
|
||||
((< ctx-pct 80) (theme-color :input-prompt))
|
||||
(t (theme-color :error))))
|
||||
(hint-x (- chat-w (length hint-str) 2))
|
||||
(ctx-x (- hint-x 1 (length ctx-str))))
|
||||
(cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg))
|
||||
(cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg))
|
||||
(cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))
|
||||
#+end_src
|
||||
|
||||
** Sidebar
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(defun sidebar-lines ()
|
||||
"Collect all sidebar lines as (text . color-key) pairs."
|
||||
(let* ((msgs (st :messages))
|
||||
(last-gt (loop for i from (1- (length msgs)) downto 0
|
||||
for m = (aref msgs i)
|
||||
when (getf m :gate-trace)
|
||||
return (getf m :gate-trace)))
|
||||
(blocked (loop for i below (length msgs)
|
||||
for m = (aref msgs i)
|
||||
sum (loop for g in (getf m :gate-trace)
|
||||
count (eq (getf g :result) :blocked))))
|
||||
(ver (or (st :daemon-version) ""))
|
||||
(ver-label (if (> (length ver) 0) (format nil "passepartout ~a" ver) "passepartout"))
|
||||
(dot (if (st :connected) "●" "○"))
|
||||
(dot-color (if (st :connected) :dot-connected :dot-disconnected)))
|
||||
(append
|
||||
;; Gate Trace
|
||||
(list (cons "GATE TRACE" :accent))
|
||||
(if last-gt
|
||||
(mapcan (lambda (g)
|
||||
(let* ((name (getf g :gate))
|
||||
(result (getf g :result))
|
||||
(reason (getf g :reason))
|
||||
(glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?")))
|
||||
(color (case result
|
||||
(:passed :tool-done)
|
||||
(:blocked :error)
|
||||
(:approval :input-prompt)
|
||||
(t :dim))))
|
||||
(if reason
|
||||
(list (cons (format nil " ~a ~a" glyph name) color)
|
||||
(cons (format nil " ~a" reason) :dim))
|
||||
(list (cons (format nil " ~a ~a" glyph name) color)))))
|
||||
last-gt)
|
||||
(list (cons " (none)" :dim)))
|
||||
;; Rules
|
||||
(list (cons "" nil))
|
||||
(list (cons "RULES" :accent))
|
||||
(list (cons (format nil " ~d active" (or (st :rule-count) 0)) :agent-fg))
|
||||
(list (cons (format nil " ~d blocked" blocked)
|
||||
(if (> blocked 0) :error :dim)))
|
||||
;; Cost
|
||||
(list (cons "" nil))
|
||||
(list (cons "COST" :accent))
|
||||
(list (cons (format nil " $~,2f" (or (st :session-cost) 0.0)) :status-fg))
|
||||
;; Files
|
||||
(list (cons "" nil))
|
||||
(list (cons "FILES" :accent))
|
||||
(list (cons " (not yet)" :dim))
|
||||
;; spacer
|
||||
(list (cons "" nil))
|
||||
;; Version footer — rendered at h-2, not in the loop
|
||||
(list (cons (format nil "~a ~a" dot ver-label) dot-color)))))
|
||||
|
||||
(defun view-sidebar (fb w h)
|
||||
(let* ((w (or (and (numberp w) (> w 0) w) 80))
|
||||
(h (or (and (numberp h) (> h 0) h) 24))
|
||||
(x (- w (or (st :sidebar-width) 42)))
|
||||
(lines (sidebar-lines))
|
||||
(content-lines (butlast lines))
|
||||
(footer-line (car (last lines))))
|
||||
(cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg (theme-color :bg-panel))
|
||||
(loop for (text . color-key) in content-lines
|
||||
for y from 0
|
||||
when text
|
||||
do (cl-tty.backend:draw-text fb (+ x 2) y text
|
||||
(if color-key (theme-color color-key) (theme-color :dim))
|
||||
(theme-color :bg-panel)))
|
||||
;; Version footer at h-2
|
||||
(when footer-line
|
||||
(cl-tty.backend:draw-text fb (+ x 2) (- h 2) (car footer-line)
|
||||
(theme-color (cdr footer-line))
|
||||
(theme-color :bg-panel)))))
|
||||
#+END_SRC
|
||||
|
||||
** Redraw (dirty-flag dispatch)
|
||||
#+begin_src lisp
|
||||
(defun redraw (fb w h)
|
||||
(setq w (or (and (numberp w) (> w 0) w) 80)
|
||||
h (or (and (numberp h) (> h 0) h) 24))
|
||||
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
|
||||
(handler-case
|
||||
(progn
|
||||
(cl-tty.backend:with-frame (fb)
|
||||
(cl-tty.backend:draw-rect fb 0 0 w h :bg (theme-color :bg))
|
||||
(view-status fb w h)
|
||||
(view-chat fb w h)
|
||||
(view-input fb w h)
|
||||
(when (sidebar-visible-p w)
|
||||
(view-sidebar fb w h)))
|
||||
(setf (st :dirty) (list nil nil nil)))
|
||||
(error (c)
|
||||
(add-msg :system (format nil "* Render error: ~a *" c))))))
|
||||
|
||||
#+END_SRC
|
||||
|
||||
* v0.7.2 — Gate Trace
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun gate-trace-lines (trace)
|
||||
"Convert gate-trace plist to display lines."
|
||||
(let ((lines nil))
|
||||
(dolist (entry trace)
|
||||
(let* ((gate (getf entry :gate))
|
||||
(result (getf entry :result))
|
||||
(reason (getf entry :reason))
|
||||
(name (or gate "unknown"))
|
||||
(color (case result
|
||||
(:passed :tool-done)
|
||||
(:blocked :error)
|
||||
(:approval :accent)
|
||||
(t :dim)))
|
||||
(prefix (case result
|
||||
(:passed " \u2713 ")
|
||||
(:blocked " \u2717 ")
|
||||
(:approval " \u2192 ")
|
||||
(t " ? ")))
|
||||
(text (format nil "~a~a~@[~a~]~@[~a~]"
|
||||
prefix name
|
||||
(when reason (format nil ": ~a" reason))
|
||||
(if (eq result :approval) " (HITL required)" ""))))
|
||||
(push (cons text (list :fgcolor color)) lines)))
|
||||
(nreverse lines)))
|
||||
#+END_SRC
|
||||
|
||||
* Test Suite
|
||||
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tui-view-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:tui-view-suite))
|
||||
|
||||
(in-package :passepartout-tui-view-tests)
|
||||
|
||||
(def-suite tui-view-suite :description "TUI view rendering helpers")
|
||||
(in-suite tui-view-suite)
|
||||
|
||||
(test test-markdown-bold
|
||||
"parse-inline detects **bold**."
|
||||
(let ((nodes (cl-tty.markdown:parse-inline "hello **world**!")))
|
||||
(is (= 3 (length nodes)))
|
||||
(is (eq :bold (getf (second nodes) :type)))))
|
||||
|
||||
(test test-markdown-plain
|
||||
"parse-inline returns text node for plain input."
|
||||
(let ((nodes (cl-tty.markdown:parse-inline "plain")))
|
||||
(is (= 1 (length nodes)))
|
||||
(is (eq :text (getf (first nodes) :type)))))
|
||||
|
||||
(test test-markdown-url
|
||||
"parse-inline returns text nodes including URLs (no built-in auto-link)."
|
||||
(let ((nodes (cl-tty.markdown:parse-inline "see https://example.com for more")))
|
||||
(is (>= (length nodes) 1))))
|
||||
|
||||
(test test-markdown-blocks
|
||||
"parse-blocks detects code blocks."
|
||||
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
|
||||
(nodes (cl-tty.markdown:parse-blocks text)))
|
||||
(is (= 3 (length nodes)))
|
||||
(is (eq :code-block (getf (second nodes) :type)))
|
||||
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline)
|
||||
(getf (second nodes) :content))))))
|
||||
|
||||
(test test-markdown-blocks-no-close
|
||||
"parse-blocks returns code-block even when unclosed."
|
||||
(let* ((text "```~%unclosed code")
|
||||
(nodes (cl-tty.markdown:parse-blocks text)))
|
||||
(is (eq :code-block (getf (first nodes) :type)))))
|
||||
|
||||
(test test-syntax-highlight
|
||||
"highlight-code returns segment pairs for Lisp code."
|
||||
(let ((result (cl-tty.markdown:highlight-code "(defun foo (x) (+ x 1))" "lisp")))
|
||||
(is (listp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-syntax-highlight-keyword
|
||||
"highlight-code classifies keywords."
|
||||
(let ((result (cl-tty.markdown:highlight-code "(let ((x 1)) (+ x 2))" "lisp")))
|
||||
(is (find :keyword result :key #'cdr))))
|
||||
|
||||
(test test-syntax-highlight-function
|
||||
"highlight-code classifies function calls."
|
||||
(let ((result (cl-tty.markdown:highlight-code "(+ 1 2)" "lisp")))
|
||||
(is (listp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-gate-trace-lines-passed
|
||||
"Contract 9: gate-trace-lines for passed gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
'((:gate "path" :result :passed)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (eq :tool-done (getf (cdar lines) :fgcolor)))))
|
||||
|
||||
(test test-gate-trace-lines-blocked
|
||||
"Contract 9: gate-trace-lines for blocked gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
'((:gate "shell" :result :blocked :reason "rm")))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "rm" (caar lines)))))
|
||||
|
||||
(test test-gate-trace-lines-approval
|
||||
"Contract 9: gate-trace-lines for approval gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
'((:gate "network" :result :approval)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "HITL" (caar lines)))))
|
||||
|
||||
(test test-init-state-has-collapsed-gates
|
||||
"Contract v0.7.2: init-state includes :collapsed-gates field."
|
||||
(passepartout.channel-tui::init-state)
|
||||
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
|
||||
(is (null cg))))
|
||||
|
||||
(test test-sidebar-state
|
||||
"Contract v0.8.0: init-state includes :sidebar-mode (:auto) and :sidebar-width (42)."
|
||||
(passepartout.channel-tui::init-state)
|
||||
(is (eq :auto (passepartout.channel-tui::st :sidebar-mode)))
|
||||
(is (= 42 (passepartout.channel-tui::st :sidebar-width))))
|
||||
|
||||
(defun sidebar-visible-p (w)
|
||||
"Compute whether sidebar should be shown given terminal width W
|
||||
and current sidebar mode."
|
||||
(let ((mode (passepartout.channel-tui::st :sidebar-mode)))
|
||||
(or (eq mode :visible)
|
||||
(and (eq mode :auto) (> w 120)))))
|
||||
|
||||
(test test-sidebar-auto-wide
|
||||
"Contract v0.8.0: sidebar auto-shows when terminal > 120 cols."
|
||||
(passepartout.channel-tui::init-state)
|
||||
(setf (passepartout.channel-tui::st :sidebar-mode) :auto)
|
||||
(is (sidebar-visible-p 140))
|
||||
(is (not (sidebar-visible-p 100))))
|
||||
|
||||
(test test-sidebar-visible-mode
|
||||
"Contract v0.8.0: :visible mode shows sidebar regardless of width."
|
||||
(passepartout.channel-tui::init-state)
|
||||
(setf (passepartout.channel-tui::st :sidebar-mode) :visible)
|
||||
(is (sidebar-visible-p 40))
|
||||
(is (sidebar-visible-p 140)))
|
||||
|
||||
(test test-sidebar-hidden-mode
|
||||
"Contract v0.8.0: :hidden mode hides sidebar regardless of width."
|
||||
(passepartout.channel-tui::init-state)
|
||||
(setf (passepartout.channel-tui::st :sidebar-mode) :hidden)
|
||||
(is (not (sidebar-visible-p 140)))
|
||||
(is (not (sidebar-visible-p 40))))
|
||||
|
||||
(test test-status-bar-tokens
|
||||
"v0.9.0: status bar uses :status-fg and :status-bg theme tokens."
|
||||
(is (stringp (passepartout.channel-tui:theme-color :status-fg)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :status-bg))))
|
||||
|
||||
(test test-new-theme-keys
|
||||
"v0.10.0: theme has all zone keys."
|
||||
(is (stringp (passepartout.channel-tui:theme-color :bg)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :bg-panel)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :bg-element)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :bg-input)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :agent-border)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :thinking-bg)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :symbolic-border)))
|
||||
(is (stringp (passepartout.channel-tui:theme-color :text-muted))))
|
||||
#+END_SRC
|
||||
173
org/channel-tui.org
Normal file
173
org/channel-tui.org
Normal file
@@ -0,0 +1,173 @@
|
||||
#+TITLE: Passepartout TUI
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui.lisp
|
||||
|
||||
* TUI
|
||||
|
||||
Direct-rendering TUI using cl-tty backend + framebuffer. Layout by
|
||||
~compute-layout~. Three zones: status (3 lines), chat, input.
|
||||
|
||||
#+begin_src lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui.lisp
|
||||
(in-package :cl-user)
|
||||
|
||||
(ql:quickload :cl-tty :silent t)
|
||||
(ql:quickload :passepartout :silent t)
|
||||
(ql:quickload :usocket :silent t)
|
||||
(ql:quickload :bordeaux-threads :silent t)
|
||||
|
||||
(defpackage :passepartout.tui
|
||||
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.rendering :cl-tty.layout)
|
||||
(:export #:tui-main))
|
||||
(in-package :passepartout.tui)
|
||||
|
||||
(defvar *messages* (make-array 0 :fill-pointer 0 :adjustable t))
|
||||
(defvar *daemon-stream* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event"))
|
||||
(defvar *streaming-text* nil)
|
||||
(defvar *input-buf* nil)
|
||||
(defvar *cursor-pos* 0)
|
||||
(defvar *connected* nil)
|
||||
(defvar *running* t)
|
||||
|
||||
;; Input
|
||||
(defun input-insert-char (ch)
|
||||
(let ((pos *cursor-pos*))
|
||||
(setf *input-buf* (concatenate 'list (subseq *input-buf* 0 pos) (list ch)
|
||||
(subseq *input-buf* pos)))
|
||||
(incf *cursor-pos*)))
|
||||
|
||||
(defun input-delete-char ()
|
||||
(when (and *input-buf* (> *cursor-pos* 0))
|
||||
(setf *input-buf* (nconc (subseq *input-buf* 0 (1- *cursor-pos*))
|
||||
(subseq *input-buf* *cursor-pos*)))
|
||||
(decf *cursor-pos*)))
|
||||
|
||||
(defun input-string () (coerce (reverse *input-buf*) 'string))
|
||||
|
||||
(defun input-submit ()
|
||||
(let ((text (string-trim '(#\Space) (input-string))))
|
||||
(when (> (length text) 0)
|
||||
(vector-push-extend (list :role :user :content text) *messages*)
|
||||
(send-daemon `(:type :event :payload (:sensor :user-input :text ,text)))
|
||||
(setf *input-buf* nil *cursor-pos* 0))))
|
||||
|
||||
;; Daemon
|
||||
(defun send-daemon (msg)
|
||||
(let ((s *daemon-stream*))
|
||||
(when (and s (open-stream-p s))
|
||||
(handler-case
|
||||
(let ((str (prin1-to-string msg)))
|
||||
(format s "~6,'0X~A" (length str) str)
|
||||
(finish-output s))
|
||||
(error () nil)))))
|
||||
|
||||
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||
(handler-case
|
||||
(let ((s (usocket:socket-connect host port :timeout 5)))
|
||||
(setf *daemon-stream* (usocket:socket-stream s) *connected* t)
|
||||
(bt:make-thread (lambda () (reader-loop)) :name "tui-reader")
|
||||
(vector-push-extend '(:role :system :content "* Connected *") *messages*))
|
||||
(error (c)
|
||||
(vector-push-extend (list :role :system :content
|
||||
(format nil "* Connection failed: ~A *" c))
|
||||
*messages*))))
|
||||
|
||||
(defun reader-loop ()
|
||||
(loop while *running*
|
||||
for msg = (handler-case
|
||||
(let* ((hdr (make-string 6)) (n 0))
|
||||
(loop while (< n 6)
|
||||
do (let ((ch (read-char *daemon-stream* nil)))
|
||||
(unless ch (return-from reader-loop nil))
|
||||
(setf (char hdr n) ch) (incf n)))
|
||||
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
|
||||
(buf (make-string (or len 0))))
|
||||
(when (and len (> len 0))
|
||||
(loop for i from 0 below len
|
||||
do (let ((ch (read-char *daemon-stream* nil)))
|
||||
(unless ch (return-from reader-loop nil))
|
||||
(setf (char buf i) ch)))
|
||||
(let ((*read-eval* nil)) (read-from-string buf)))))
|
||||
(error () nil))
|
||||
if msg do (bt:with-lock-held (*event-lock*) (push msg *event-queue*))
|
||||
else do (sleep 0.5)))
|
||||
|
||||
;; Render
|
||||
(defun render-frame (fb w h)
|
||||
(backend-clear fb)
|
||||
(let ((fg (if *connected* "#00FF00" "#FF4444")))
|
||||
(draw-text fb 1 1
|
||||
(format nil " Passepartout ~a [CHAT] msgs:~d"
|
||||
(if *connected* "● Connected" "○ Disconnected")
|
||||
(length *messages*))
|
||||
fg nil)
|
||||
(draw-text fb 1 2 " Ctrl+P: palette Ctrl+Q: quit /help: help" "#888888" nil))
|
||||
(let ((y 4))
|
||||
(loop for i from (1- (length *messages*)) downto 0
|
||||
for msg = (aref *messages* i)
|
||||
do (let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(fg (case role (:user "#00FF00") (:agent "#FFFFFF")
|
||||
(:system "#FFFF00") (t "#888888")))
|
||||
(pfx (case role (:user "> ") (:agent " ") (:system "* ") (t " ")))))
|
||||
(draw-text fb 1 y (concatenate 'string pfx content) fg nil)
|
||||
(incf y))
|
||||
(when (> y (- h 3)) (loop-finish))))
|
||||
(draw-text fb 1 (- h 1) (concatenate 'string "> " (input-string)) "#FFFFFF" "#0F3460"))
|
||||
|
||||
;; Event loop
|
||||
(defun tui-main ()
|
||||
(setf *running* t *messages* (make-array 0 :fill-pointer 0 :adjustable t))
|
||||
(connect-daemon)
|
||||
(with-raw-terminal
|
||||
(with-terminal (be w h)
|
||||
(let ((prev-fb (make-framebuffer w h))
|
||||
(curr-fb (make-framebuffer w h)))
|
||||
(loop while *running* do
|
||||
(bt:with-lock-held (*event-lock*)
|
||||
(dolist (msg (nreverse *event-queue*))
|
||||
(let* ((payload (getf msg :payload)) (text (getf payload :text))
|
||||
(type (getf msg :type)))
|
||||
(cond
|
||||
((and (eq type :stream-chunk) text (not (string= text "")))
|
||||
(if *streaming-text*
|
||||
(setf *streaming-text* (concatenate 'string *streaming-text* text))
|
||||
(setf *streaming-text* text
|
||||
*messages* (let ((v (make-array (1+ (length *messages*))
|
||||
:fill-pointer (1+ (length *messages*))
|
||||
:adjustable t)))
|
||||
(loop for i below (length *messages*)
|
||||
do (setf (aref v i) (aref *messages* i)))
|
||||
(setf (aref v (length *messages*))
|
||||
(list :role :thinking :content text))
|
||||
v))))
|
||||
((and (eq type :stream-chunk) (string= text ""))
|
||||
(setf *streaming-text* nil))
|
||||
(text
|
||||
(vector-push-extend (list :role :agent :content text) *messages*)))))
|
||||
(setf *event-queue* nil))
|
||||
(multiple-value-bind (type data) (read-event be :timeout 0)
|
||||
(declare (ignore type))
|
||||
(when (key-event-p data)
|
||||
(let ((k (key-event-key data)))
|
||||
(cond
|
||||
((eq k :escape) (when *streaming-text* (setf *streaming-text* nil)))
|
||||
((eq k :enter) (input-submit))
|
||||
((eq k :backspace) (input-delete-char))
|
||||
((eq k :left) (when (> *cursor-pos* 0) (decf *cursor-pos*)))
|
||||
((eq k :right) (when (< *cursor-pos* (length *input-buf*))
|
||||
(incf *cursor-pos*)))
|
||||
((eq k :ctrl-u) (setf *input-buf* nil *cursor-pos* 0))
|
||||
((eq k :ctrl-a) (setf *cursor-pos* 0))
|
||||
((eq k :ctrl-e) (setf *cursor-pos* (length *input-buf*)))
|
||||
((eq k :ctrl-d) (when (null *input-buf*) (setf *running* nil)))
|
||||
((eq k :ctrl-q) (setf *running* nil))
|
||||
(t (let ((chr (when (keywordp k)
|
||||
(let ((s (string k)))
|
||||
(when (= (length s) 1) (char-downcase (char s 0)))))))
|
||||
(when chr (input-insert-char chr))))))))
|
||||
(render-frame curr-fb w h)
|
||||
(flush-framebuffer prev-fb curr-fb be)
|
||||
(rotatef prev-fb curr-fb)
|
||||
(sleep 0.05))))))
|
||||
#+end_src
|
||||
528
org/core-act.org
Normal file
528
org/core-act.org
Normal file
@@ -0,0 +1,528 @@
|
||||
#+TITLE: Stage 3: Act (act.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:act:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-act.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Act stage is where cognition meets reality. After the Probabilistic engine proposes an action and the Deterministic engine verifies it, Act executes it through the appropriate actuator.
|
||||
|
||||
An actuator is a function that takes (action context) and performs a physical operation: send a message to the TUI, execute a shell command, call a Telegram API, write to a file. Actuators are registered in a global hash table (~*actuator-registry*~) and dispatched by name.
|
||||
|
||||
The key architectural choice: **actuators are not privileged**. The same dispatch mechanism that routes to :shell or :file also routes to :telegram or :signal. There is no special handling for dangerous actuators — safety is enforced at the Reason stage by the deterministic engine, not by Act. This means:
|
||||
|
||||
1. Adding a new actuator requires no changes to the core — just register it
|
||||
2. Safety is centralized in the deterministic gates, not scattered across actuator implementations
|
||||
3. Every actuator benefits from the same security checks (the Dispatcher, the Policy)
|
||||
|
||||
** Why Dispatch-Action Verifies Again?
|
||||
|
||||
The Reason stage already ran every proposed action through the deterministic engine. So why does ~loop-gate-act~ call ~cognitive-verify~ again?
|
||||
|
||||
Because a skill's deterministic gate runs during Reason, but between Reason and Act, the action might have been transformed by the pipeline (metadata added, format normalized). The last-mile verification catches any transformation that might have introduced an unsafe property. It's the same philosophy as "trust but verify" — the second check is cheap and catches a class of bugs that would otherwise be silent data corruption.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-gate-act signal): the final pipeline stage. Handles HITL
|
||||
~:approval-required~ (suspends action), runs last-mile
|
||||
~cognitive-verify~ on approved actions, dispatches via
|
||||
~action-dispatch~, sets ~:status :acted~, returns feedback.
|
||||
2. (act-gate signal): thin alias for ~loop-gate-act~.
|
||||
3. (action-dispatch approved signal): routes approved actions to
|
||||
registered actuators by ~:target~ keyword.
|
||||
4. (tui-enrich-response action context): enriches the outgoing action
|
||||
plist with sidebar fields — ~:block-counts~, ~:context-usage~,
|
||||
~:modified-files~, ~:session-cost~ (v0.8.0) — plus existing
|
||||
~:rule-count~ and ~:foveal-id~ (v0.4.0). Each field is
|
||||
~fboundp~-guarded; missing skills produce nil. Called from the
|
||||
~:tui~ actuator lambda.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Actuator Configuration
|
||||
|
||||
~*actuator-default*~ determines where actions go when no explicit target is specified. Defaults to ~:cli~.
|
||||
|
||||
~*actuator-silent*~ lists actuator targets that don't generate tool-output feedback. For example, sending a message to the CLI or Emacs doesn't need to produce a tool-output event — the user can see the message directly. This prevents redundant feedback loops.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-default* :cli
|
||||
"The actuator used when no explicit target is specified.")
|
||||
|
||||
#+end_src
|
||||
** *actuator-silent*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-silent* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.")
|
||||
|
||||
#+end_src
|
||||
** actuator-initialize
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun actuator-initialize ()
|
||||
"Register core actuators and load configuration."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
(when def
|
||||
(setf *actuator-default* (intern (string-upcase def) :keyword)))
|
||||
(when silent
|
||||
(setf *actuator-silent*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string silent :separator '(#\,))))))
|
||||
|
||||
(register-actuator :system #'action-system-execute)
|
||||
(register-actuator :tool #'action-tool-execute)
|
||||
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((meta (getf action :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
;; Enrich response with differentiator visualization data
|
||||
(setf (getf (getf action :payload) :rule-count)
|
||||
(if (boundp '*hitl-pending*)
|
||||
(hash-table-count *hitl-pending*)
|
||||
0))
|
||||
(setf (getf (getf action :payload) :foveal-id)
|
||||
(getf context :foveal-id))
|
||||
;; v0.8.0: sidebar enrichment via fboundp guards
|
||||
(when (fboundp 'dispatcher-block-counts-summary)
|
||||
(setf (getf (getf action :payload) :block-counts)
|
||||
(dispatcher-block-counts-summary)))
|
||||
(when (fboundp 'context-usage-percentage)
|
||||
(setf (getf (getf action :payload) :context-usage)
|
||||
(context-usage-percentage)))
|
||||
(when (fboundp 'tool-modified-files-summary)
|
||||
(setf (getf (getf action :payload) :modified-files)
|
||||
(tool-modified-files-summary)))
|
||||
(when (fboundp 'cost-session-summary)
|
||||
(setf (getf (getf action :payload) :session-cost)
|
||||
(cost-session-summary)))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
#+end_src
|
||||
|
||||
** TUI Differentiator Enrichment (v0.4.0, extended v0.8.0)
|
||||
|
||||
The TUI actuator is the last point in the pipeline before the response leaves the daemon. It enriches the action plist with fields that power the TUI's differentiator visualizations:
|
||||
|
||||
- ~:rule-count~ = ~(hash-table-count *hitl-pending*)~ — the number of pending HITL actions. The user watches this counter tick as they teach the agent their preferences. (v0.4.0)
|
||||
- ~:foveal-id~ = the current foveal focus from the signal context — enables the TUI's focus map status line. (v0.4.0)
|
||||
- ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged. (v0.4.0)
|
||||
|
||||
v0.8.0 adds four sidebar fields via ~fboundp~ guards — same pattern as
|
||||
~core-reason.lisp~'s calls into token-economics, awareness, and time skills.
|
||||
Each field degrades gracefully to nil when its source skill is not loaded:
|
||||
|
||||
- ~:block-counts~ = ~(dispatcher-block-counts-summary)~ — per-gate block tallies from ~security-dispatcher~. Powers the sidebar's Protection panel.
|
||||
- ~:context-usage~ = ~(context-usage-percentage)~ — token budget percentage from ~token-economics~. Powers the sidebar's Context gauge.
|
||||
- ~:modified-files~ = ~(tool-modified-files-summary)~ — files modified this turn from ~programming-tools~. Powers the sidebar's Files panel.
|
||||
- ~:session-cost~ = ~(cost-session-summary)~ — cumulative cost data from ~cost-tracker~. Powers the sidebar's Cost panel.
|
||||
|
||||
The enrichment is added inside the existing ~:tui~ actuator lambda (one block
|
||||
after the ~:rule-count~ and ~:foveal-id~ enrichment). No new actuator is
|
||||
registered; no new ASDF component is added. The contract is: each field
|
||||
arrives via ~fboundp~ guard and is silently nil when unavailable.
|
||||
|
||||
** Action Dispatch (action-dispatch)
|
||||
|
||||
Routes an approved action to its registered actuator. The target is resolved in priority order:
|
||||
|
||||
1. The explicit ~:target~ field on the action
|
||||
2. The source of the original signal (reply to the sender)
|
||||
3. The default actuator (~:cli~)
|
||||
|
||||
Heartbeats are silently dropped here — they should never generate an actuation.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-dispatch (action context)
|
||||
"Route an approved action to its registered actuator."
|
||||
(let ((payload (proto-get action :payload)))
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from action-dispatch nil))
|
||||
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead
|
||||
(actual-target (if (and (eq target :system)
|
||||
(getf meta :reply-stream)
|
||||
(ignore-errors (open-stream-p (getf meta :reply-stream))))
|
||||
:tui
|
||||
target))
|
||||
(actuator-fn (gethash actual-target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" actual-target))))))
|
||||
#+end_src
|
||||
|
||||
** System Actuator (action-system-execute)
|
||||
|
||||
Handles internal harness commands: ~:eval~ (execute arbitrary Lisp) and ~:message~ (log to the harness log). This is how the deterministic engine communicates results back to the user.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-system-execute (action context)
|
||||
"Execute internal harness commands."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :action)))
|
||||
(case cmd
|
||||
(:eval
|
||||
(eval (let ((*read-eval* nil)) (read-from-string (getf payload :code)))))
|
||||
(:message
|
||||
(log-message "ACT [System]: ~a" (getf payload :text)))
|
||||
(t
|
||||
(log-message "ACT ERROR [System]: Unknown command '~s'" cmd)))))
|
||||
#+end_src
|
||||
|
||||
** Tool Actuator (action-tool-execute)
|
||||
|
||||
Executes a registered cognitive tool. Cognitive tools are registered via ~def-cognitive-tool~ in the package.lisp and are the primary way the LLM interacts with the outside world.
|
||||
|
||||
The function handles:
|
||||
- Tool dispatch by name (case-insensitive lookup)
|
||||
- Argument normalization (if the arguments are nested in a list, they're flattened)
|
||||
- Result formatting (structured results are sent back to the source)
|
||||
- Error handling (tool errors produce ~:tool-error~ events, not crashes)
|
||||
|
||||
The tool's return value is packed into a ~:tool-output~ event and fed back into the pipeline, where it becomes the next perception. This is how the agent "sees" the result of its actions.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-tool-execute (action context)
|
||||
"Execute a registered cognitive tool."
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
;; v0.7.2: snapshot before destructive tool execution
|
||||
(when (and tool (not (cognitive-tool-read-only-p tool)))
|
||||
(undo-snapshot))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(is-read-only (cognitive-tool-read-only-p tool))
|
||||
(cache-key (when is-read-only (tool-cache-key tool-name clean-args)))
|
||||
(cached (when cache-key (gethash cache-key *tool-cache*)))
|
||||
(raw-result (if cached
|
||||
(progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached)
|
||||
(let* ((res (call-with-tool-timeout tool-name
|
||||
(lambda () (funcall (cognitive-tool-body tool) clean-args)))))
|
||||
(when (and is-read-only cache-key)
|
||||
(setf (gethash cache-key *tool-cache*) res))
|
||||
res))))
|
||||
;; Timeout: propagate error
|
||||
(when (and (listp raw-result) (eq (getf raw-result :status) :error))
|
||||
(return-from action-tool-execute
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name
|
||||
:MESSAGE (getf raw-result :message)))))
|
||||
(when source
|
||||
(action-dispatch (list :TYPE :REQUEST :TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result)))
|
||||
context))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name)))
|
||||
(error (c)
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
|
||||
#+end_src
|
||||
|
||||
** v0.7.2 — Tool Execution Hardening
|
||||
#+begin_src lisp
|
||||
(defvar *tool-timeouts* (make-hash-table :test 'equal)
|
||||
"Per-tool timeout in seconds. Default 120s.")
|
||||
|
||||
;; Defaults: shell=300s, search-files=30s, eval-form=10s
|
||||
(setf (gethash "shell" *tool-timeouts*) 300)
|
||||
(setf (gethash "search-files" *tool-timeouts*) 30)
|
||||
(setf (gethash "eval-form" *tool-timeouts*) 10)
|
||||
|
||||
(defun tool-timeout (tool-name)
|
||||
"Return timeout for tool-name, default 120 seconds."
|
||||
(gethash (string-downcase (string tool-name)) *tool-timeouts* 120))
|
||||
|
||||
(defun call-with-tool-timeout (tool-name fn)
|
||||
"Execute FN within the timeout for TOOL-NAME.
|
||||
On timeout, returns (:status :error :message ...)."
|
||||
(let ((timeout (tool-timeout tool-name)))
|
||||
(handler-case
|
||||
(sb-ext:with-timeout timeout
|
||||
(funcall fn))
|
||||
(sb-ext:timeout (c)
|
||||
(declare (ignore c))
|
||||
(list :status :error :message
|
||||
(format nil "Timed out after ~a second~:p" timeout))))))
|
||||
|
||||
(defun verify-write (filepath expected-content)
|
||||
"Verify that FILEPATH contains EXPECTED-CONTENT after write.
|
||||
Returns T on match, logs and returns NIL on mismatch or read error."
|
||||
(handler-case
|
||||
(let ((actual (uiop:read-file-string filepath)))
|
||||
(if (string= expected-content actual)
|
||||
t
|
||||
(progn
|
||||
(log-message "WRITE-VERIFY: Mismatch in ~a" filepath)
|
||||
nil)))
|
||||
(error (c)
|
||||
(log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c)
|
||||
nil)))
|
||||
|
||||
;; v0.7.2: read-only tool response cache
|
||||
(defvar *tool-cache* (make-hash-table :test 'equal)
|
||||
"Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.")
|
||||
|
||||
(defun tool-cache-key (tool-name args)
|
||||
"Build a cache key from TOOL-NAME and ARGS."
|
||||
(format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args)))
|
||||
|
||||
(defun tool-cache-clear ()
|
||||
"Clear the read-only tool response cache."
|
||||
(clrhash *tool-cache*))
|
||||
#+end_src
|
||||
|
||||
** Tool Result Formatting (tool-result-format)
|
||||
|
||||
Converts a tool's return value into a human-readable string for display to the user. Handles structured results (plists with ~:status~, ~:content~, ~:message~) and plain values.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun tool-result-format (tool-name result)
|
||||
"Format a tool result for display."
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond
|
||||
((and (eq status :success) content) (format nil "~a" content))
|
||||
((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
#+end_src
|
||||
|
||||
** Act Gate (Stage 3)
|
||||
|
||||
The final stage of the metabolic pipeline. It receives a signal that has been reasoned (has an ~:approved-action~) and dispatches it.
|
||||
|
||||
The gate runs a last-mile deterministic check on the approved action before execution. This catches any issues introduced during pipeline processing (e.g., metadata added by Perceive that changes the action's format).
|
||||
|
||||
After dispatch, the gate captures any feedback produced by the actuation (tool output, error events) and returns it to the loop for the next cognitive cycle.
|
||||
|
||||
*** loop-gate-act
|
||||
|
||||
The main act pipeline stage.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-act (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation.
|
||||
For approval-required actions, creates a Flight Plan instead of executing."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(signal-status (getf signal :status))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
;; HITL: if the approved action requires human approval,
|
||||
;; create a Flight Plan (Emacs) and HITL entry (all gateways).
|
||||
(when (and approved
|
||||
(eq (getf approved :level) :approval-required))
|
||||
(let* ((payload (getf approved :payload))
|
||||
(blocked-action (getf payload :action))
|
||||
(hitl (hitl-create blocked-action)))
|
||||
(log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token))
|
||||
(dispatcher-flight-plan-create blocked-action)
|
||||
(setf (getf signal :status) :suspended)
|
||||
(action-dispatch (list :target source
|
||||
:payload (list :text (getf hitl :message)))
|
||||
signal)
|
||||
(setf approved nil)
|
||||
(setf feedback nil)))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (cognitive-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT))
|
||||
(not (eq (getf verified :level) :approval-required))
|
||||
(not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(log-message "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf feedback verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
(case type
|
||||
(:REQUEST (action-dispatch signal signal))
|
||||
(:LOG (action-dispatch signal signal))
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (action-dispatch approved signal)))
|
||||
(cond
|
||||
((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
((and result (not (member target *actuator-silent*)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))
|
||||
(when source (action-dispatch signal signal)))))
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
#+end_src
|
||||
|
||||
*** act-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~act-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-act~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun act-gate (signal)
|
||||
(loop-gate-act signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the act gate correctly processes an approved action and sets the signal status to ~:acted~.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
(test test-tool-timeout-shell
|
||||
"Contract v0.7.2: shell timeout is 300 seconds."
|
||||
(is (= 300 (passepartout::tool-timeout "shell"))))
|
||||
|
||||
(test test-tool-timeout-unknown
|
||||
"Contract v0.7.2: unknown tool gets default 120s."
|
||||
(is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
|
||||
|
||||
(test test-verify-write-match
|
||||
"Contract v0.7.2: verify-write returns T on match."
|
||||
(let ((path "/tmp/passepartout-verify-test.org")
|
||||
(content "test content"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(is (passepartout::verify-write path content))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-tool-timeout-enforcement
|
||||
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
|
||||
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
|
||||
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "sleep-forever"
|
||||
:read-only-p nil
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(sleep 10)
|
||||
"done")))
|
||||
(unwind-protect
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(result (passepartout::action-tool-execute action ctx)))
|
||||
(is (eq :EVENT (getf result :TYPE)))
|
||||
(let ((payload (getf result :PAYLOAD)))
|
||||
(is (eq :tool-error (getf payload :SENSOR)))
|
||||
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
|
||||
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
|
||||
|
||||
(test test-tool-cache-read-only
|
||||
"Contract v0.7.2: read-only tool results are cached and reused."
|
||||
(let ((call-count 0))
|
||||
(setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "cache-test"
|
||||
:read-only-p t
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(incf call-count)
|
||||
(list :status :success :content (format nil "call ~d" call-count)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(clrhash passepartout::*tool-cache*)
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(r1 (passepartout::action-tool-execute action ctx))
|
||||
(r2 (passepartout::action-tool-execute action ctx)))
|
||||
(is (= 1 call-count) "Second call should hit cache, not re-execute")
|
||||
(let ((p1 (getf r1 :PAYLOAD))
|
||||
(p2 (getf r2 :PAYLOAD)))
|
||||
(is (string= (getf (getf p1 :RESULT) :CONTENT)
|
||||
(getf (getf p2 :RESULT) :CONTENT))))))
|
||||
(remhash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(clrhash passepartout::*tool-cache*))))
|
||||
#+end_src
|
||||
55
org/core-manifest.org
Normal file
55
org/core-manifest.org
Normal file
@@ -0,0 +1,55 @@
|
||||
#+TITLE: System Manifest (manifest.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:manifest:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/passepartout.asd
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Manifest is the ASDF system definition for Passepartout. It defines what files belong to the harness, which external libraries are required, and how the test infrastructure is organized.
|
||||
|
||||
The ~passepartout.asd~ file tangled from this manifest is what ~ql:quickload :passepartout~ reads to load the system. The files are loaded in the order listed here — dependencies first, then each pipeline stage in order.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Main System
|
||||
|
||||
The core system. The combined ~:depends-on~ list pulls in every external library the agent needs: networking (usocket, dexador, hunchentoot), concurrency (bordeaux-threads), utilities (uiop, cl-ppcre, cl-json, str), security (ironclad), and configuration (cl-dotenv, uuid).
|
||||
|
||||
Components are loaded in sequence (~:serial t~): package first (defines the public API), then skills (does the defskill macro), then communication (defines the protocol), then memory (defines org-object), then context (defines peripheral vision), then each pipeline stage in order (perceive, reason, act), then doctor (diagnostics), then loop (orchestration).
|
||||
|
||||
#+begin_src lisp
|
||||
(defsystem :passepartout
|
||||
:name "Passepartout"
|
||||
:author "Amr Gharbeia"
|
||||
:version "0.4.3"
|
||||
:license "AGPLv3"
|
||||
:description "The Probabilistic-Deterministic Lisp Machine"
|
||||
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
|
||||
:serial t
|
||||
:components ((:file "lisp/core-package")
|
||||
(:file "lisp/core-skills")
|
||||
(:file "lisp/core-transport")
|
||||
(:file "lisp/core-memory")
|
||||
(:file "lisp/core-perceive")
|
||||
(:file "lisp/core-reason")
|
||||
(:file "lisp/core-act")
|
||||
(:file "lisp/core-pipeline")))
|
||||
#+end_src
|
||||
|
||||
** Test System
|
||||
|
||||
Tests are embedded directly in each module's source file — see the `* Test Suite` section at the end of each `.org` file. No separate test system is needed.
|
||||
|
||||
** TUI System
|
||||
|
||||
The TUI is a standalone system that depends on cl-tty (pure CL terminal UI) in addition to the core system. It's loaded separately because it requires a terminal and is not needed for daemon-mode operation.
|
||||
|
||||
#+begin_src lisp
|
||||
(defsystem :passepartout/tui
|
||||
:depends-on (:passepartout :cl-tty :usocket :bordeaux-threads)
|
||||
:serial t
|
||||
:components ((:file "lisp/channel-tui-state")
|
||||
(:file "lisp/channel-tui-view")
|
||||
(:file "lisp/channel-tui-main")))
|
||||
#+end_src
|
||||
568
org/core-memory.org
Normal file
568
org/core-memory.org
Normal file
@@ -0,0 +1,568 @@
|
||||
#+TITLE: The System Memory (memory.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:memory:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-memory.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Memory module is the cognitive bedrock of Passepartout. It is not a database; it is the agent's live, active brain state. Every perception, every action, every decision is recorded here.
|
||||
|
||||
Traditional architectures rely on external databases (SQLite, vector DBs, JSON files) which introduce I/O latency, structural impedance, and serialization overhead. Passepartout chooses a different path: the **Single Address Space**. By treating the entire knowledge base as a graph of Lisp pointers in RAM, we achieve microsecond recollection and total structural transparency.
|
||||
|
||||
The memory system has three layers:
|
||||
1. **Active memory** (~*memory-store*~) — a hash table mapping IDs to ~memory-object~ instances. This is what the agent queries during reasoning.
|
||||
2. **Immutable history** (~*memory-history*~) — an append-only hash table keyed by SHA-256 Merkle hash. Every version of every object that has ever existed is preserved here.
|
||||
3. **Snapshot stack** (~*memory-snapshots*~) — point-in-time copies of active memory for rollback recovery. Up to 20 snapshots are retained.
|
||||
|
||||
** Why Merkle Hashes?
|
||||
|
||||
Every ~memory-object~ carries a ~hash~ field computed from its ID, type, attributes, content, and children. This hash is deterministic: the same data always produces the same hash.
|
||||
|
||||
The hash serves three purposes:
|
||||
1. **Integrity verification** — detect corruption or tampering
|
||||
2. **Deduplication** — if an object already exists in history, we reuse the existing entry
|
||||
3. **Change detection** — compare hashes to find what changed between snapshots
|
||||
|
||||
** Why Snapshots Instead of Git?
|
||||
|
||||
Git tracks changes to files. Passepartout tracks changes to live memory state. The snapshot system captures the entire active memory at a point in time, enabling full rollback to any previous state. This is necessary because:
|
||||
|
||||
1. The agent modifies memory continuously (learning, noting, deciding) — there's no discrete "commit" boundary
|
||||
2. Memory corruption from a bad LLM output can affect multiple objects — snapshot rollback restores all of them atomically
|
||||
3. Git can't snapshot the running Lisp image's hash tables
|
||||
|
||||
The tradeoff is memory usage: each snapshot is a deep copy of every object in active memory. 20 snapshots means 20x the active memory size. For a typical knowledge base of 10,000 objects, this is manageable (~100MB for 20 snapshots).
|
||||
|
||||
** Contract
|
||||
|
||||
1. (ingest-ast ast &key scope): stores AST nodes in ~*memory-store*~.
|
||||
Detaches children, gives each an ID, computes Merkle hash, and
|
||||
populates the ~:vector~ slot via ~embeddings-compute~. Returns the
|
||||
root ID string.
|
||||
2. (memory-object-hash object): returns the SHA-256 Merkle hash of the
|
||||
object's content. Hash is deterministic — same content → same hash.
|
||||
3. (memory-object-get id): retrieves a stored object by ID, or nil.
|
||||
4. (snapshot-memory): deep-copies ~*memory-store*~ to ~*memory-snapshots*~.
|
||||
5. (rollback-memory snap-index): restores ~*memory-store*~ from a snapshot.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** The Object Store
|
||||
|
||||
~*memory-store*~ holds the agent's current state. ~*memory-history*~ holds every past version, keyed by Merkle hash.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-store* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
** *memory-history*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-history* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Object Lookup (memory-object-get)
|
||||
|
||||
Retrieve a single object by its ID from active memory. Returns nil if the ID doesn't exist.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-object-get (id)
|
||||
"Retrieves an memory-object by ID from *memory-store*."
|
||||
(gethash id *memory-store*))
|
||||
#+end_src
|
||||
|
||||
** Object Search by Attribute (memory-objects-by-attribute)
|
||||
|
||||
Scan the entire active memory for objects whose attributes plist contains a specific key-value pair. For example, finding all objects with ~:TODO "APPROVED"~ (used by the Dispatcher to find approved flight plans).
|
||||
|
||||
This is a full scan — O(n) over all objects. For the typical knowledge base size (< 10,000 objects), this is microsecond-fast. For larger datasets, a proper index would be needed.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-objects-by-attribute (attr value)
|
||||
"Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (equal (getf (memory-object-attributes obj) attr) value)
|
||||
(push obj results)))
|
||||
*memory-store*)
|
||||
(nreverse results)))
|
||||
#+end_src
|
||||
|
||||
** ID Generation (memory-id-generate)
|
||||
|
||||
Generates a unique identifier string for a new Org node. Uses the universal time encoded in base-36 for compactness and monotonic ordering (later IDs sort after earlier ones).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-id-generate ()
|
||||
"Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs."
|
||||
(concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid)))))
|
||||
#+end_src
|
||||
|
||||
** The Data Structure (memory-object)
|
||||
|
||||
The universal data unit. Every stored entity — a note, a task, a project, a person, a decision — is an ~memory-object~. The struct has:
|
||||
|
||||
- ~id~ — unique identifier (string)
|
||||
- ~type~ — keyword (e.g., ~:HEADLINE~, ~:PROPERTY_DRAWER~)
|
||||
- ~attributes~ — property list (e.g., ~(:TITLE "My Note" :TAGS ("project") :TODO "NEXT")~)
|
||||
- ~content~ — raw text content
|
||||
- ~vector~ — optional embedding vector for semantic search
|
||||
- ~parent-id~ — ID of the parent object (for tree structure)
|
||||
- ~children~ — list of child IDs
|
||||
- ~version~ — Unix timestamp of last modification
|
||||
- ~last-sync~ — Unix timestamp of last sync to disk
|
||||
- ~hash~ — SHA-256 Merkle hash for integrity verification
|
||||
- ~scope~ — scope keyword (:memex/:session/:project) for context-aware retrieval
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defstruct memory-object
|
||||
id type attributes content vector parent-id children version last-sync hash scope)
|
||||
#+end_src
|
||||
|
||||
** Serialization Support
|
||||
|
||||
Required by the Lisp runtime for saving/loading objects across image restarts via ~make-load-form-saving-slots~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defmethod make-load-form ((obj memory-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
#+end_src
|
||||
|
||||
** Deep Copy
|
||||
|
||||
Creates an independent copy of an ~memory-object~, including fresh lists for attributes and children. Used by the snapshot system to capture a consistent memory state.
|
||||
|
||||
Without deep copy, a snapshot would share structure with the live memory — mutating the live memory would also mutate the snapshot, defeating the purpose of having a recovery point.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun deep-copy-memory-object (obj)
|
||||
"Creates a full copy of an memory-object, including fresh lists for attributes and children."
|
||||
(make-memory-object :id (memory-object-id obj)
|
||||
:type (memory-object-type obj)
|
||||
:attributes (copy-list (memory-object-attributes obj))
|
||||
:content (memory-object-content obj)
|
||||
:vector (memory-object-vector obj)
|
||||
:parent-id (memory-object-parent-id obj)
|
||||
:children (copy-list (memory-object-children obj))
|
||||
:version (memory-object-version obj)
|
||||
:last-sync (memory-object-last-sync obj)
|
||||
:hash (memory-object-hash obj)
|
||||
:scope (memory-object-scope obj)))
|
||||
#+end_src
|
||||
|
||||
** Merkle Tree Integrity (memory-merkle-hash)
|
||||
|
||||
Computes a deterministic SHA-256 hash from an object's identity and contents. The hash covers:
|
||||
- The object's ID and type
|
||||
- All attributes (sorted by key name for determinism)
|
||||
- The raw content text
|
||||
- The hashes of all children (making the hash a true Merkle tree — changing a descendant changes this hash)
|
||||
|
||||
This is NOT a cryptographic signature — it's an integrity check. If any part of an object or its descendants changes, the hash changes.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
#+end_src
|
||||
|
||||
** AST Ingestion (memory-ingest)
|
||||
|
||||
The primary entry point for adding data to memory. Given an Org-mode AST (a tree of plists representing headlines and their contents), it recursively:
|
||||
|
||||
1. Generates or assigns an ID to each node
|
||||
2. Computes the Merkle hash of each node
|
||||
3. Checks if the hash already exists in ~*memory-history*~ (deduplication)
|
||||
4. Stores the node in ~*memory-store*~ and ~*memory-history*~
|
||||
5. Links children to parents
|
||||
|
||||
Returns the ID of the root node.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun ingest-ast (ast &key parent-id (scope :memex))
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) ""))))
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child :parent-id id :scope scope)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory-store*)))
|
||||
(when child-obj (push (memory-object-hash child-obj) child-hashes))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (memory-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *memory-history*))
|
||||
(obj (or existing-obj
|
||||
(make-memory-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash :scope scope))))
|
||||
(unless existing-obj (setf (gethash hash *memory-history*) obj))
|
||||
(setf (gethash id *memory-store*) obj)
|
||||
;; Populate embedding vector for new objects
|
||||
(when (and raw-content (not existing-obj) (not (memory-object-vector obj)))
|
||||
(handler-case
|
||||
(setf (memory-object-vector obj)
|
||||
(embeddings-compute raw-content))
|
||||
(error (c)
|
||||
(log-message "INGEST: Embedding deferred: ~a" c))))
|
||||
id)))
|
||||
#+end_src
|
||||
|
||||
** Snapshot History (~*memory-snapshots*~)
|
||||
|
||||
A stack of CoW (copy-on-write) snapshots for rollback. When a critical error occurs, the system can roll back to any of the last 20 snapshots. Newer snapshots are prepended (index 0 = most recent).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-snapshots* nil)
|
||||
#+end_src
|
||||
|
||||
** Hash Table Copy Utility
|
||||
|
||||
Creates a fully independent copy of a hash table. Used by the rollback system to restore saved memory state from a snapshot.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-hash-table-copy (hash-table)
|
||||
"Creates an independent copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
#+end_src
|
||||
|
||||
** Memory Snapshot (memory-snapshot)
|
||||
|
||||
Captures a point-in-time copy of ~*memory-store*~. Each object is deep-copied so the snapshot is independent of ongoing mutations. The snapshot is prepended to the snapshot stack, and the stack is trimmed to 20 entries.
|
||||
|
||||
Called automatically before significant memory mutations (buffer updates from Emacs, AST ingestion). Also callable manually.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun snapshot-memory ()
|
||||
"Creates a CoW snapshot of *memory-store* for rollback recovery."
|
||||
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory-store*))))
|
||||
(maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-memory-object v))) *memory-store*)
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*)
|
||||
(when (> (length *memory-snapshots*) 20)
|
||||
(setf *memory-snapshots* (subseq *memory-snapshots* 0 20)))
|
||||
(log-message "MEMORY - CoW Memory snapshot created.")))
|
||||
#+end_src
|
||||
|
||||
** Memory Rollback (memory-rollback)
|
||||
|
||||
Restores ~*memory-store*~ to a previous snapshot. By default restores the most recent snapshot (index 0). Can specify a specific index to roll back further.
|
||||
|
||||
This is the immune system's last resort. When the metabolic loop catches an unhandled error, it calls ~(rollback-memory 0)~ to undo any memory mutations caused by the bad signal.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores *memory-store* from a snapshot. INDEX 0 = most recent."
|
||||
(let ((snapshot (nth index *memory-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data)))
|
||||
(log-message "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(log-message "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
#+end_src
|
||||
|
||||
** Persistence — Snapshot Path (~*memory-snapshot-path*~)
|
||||
|
||||
Configurable path for serialized memory state. Falls back to ~memory.snap~ in the home directory. Can be overridden via ~MEMORY_SNAPSHOT_PATH~ env var.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-snapshot-path* nil)
|
||||
|
||||
#+end_src
|
||||
** memory-snapshot-path-ensure
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-snapshot-path-ensure ()
|
||||
"Returns the path to the memory snapshot file, resolving env or default."
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Save to Disk (memory-save)
|
||||
|
||||
Serialises both ~*memory-store*~ and ~*memory-history*~ to a Lisp-readable file. The format is a plist with ~:memory~ and ~:history-store~ keys, each containing an alist of (key . object) pairs.
|
||||
|
||||
The serialization uses ~prin1~, which produces human-readable Lisp output. The file can be read with ~read~ on restart.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun save-memory-to-disk ()
|
||||
"Writes the entire memory and history store to disk as a plist."
|
||||
(let ((path (memory-snapshot-path-ensure)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(let ((memory-alist nil) (history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory-store*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *memory-history*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(log-message "MEMORY - Saved to ~a" path)))
|
||||
#+end_src
|
||||
|
||||
** Load from Disk (memory-load)
|
||||
|
||||
Restores memory state from a previously saved snapshot file. Called during boot (~main~ in ~loop.org~). If no snapshot file exists, the function returns silently and the agent starts with empty memory.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun load-memory-from-disk ()
|
||||
"Reads memory state from disk and restores *memory-store* and *memory-history*."
|
||||
(let ((path (memory-snapshot-path-ensure)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (let ((*read-eval* nil)) (read stream nil))))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
|
||||
(setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist) (setf (gethash (car kv) *memory-store*) (cdr kv)))
|
||||
(setf *memory-history* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist) (setf (gethash (car kv) *memory-history*) (cdr kv)))
|
||||
(log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*))))))
|
||||
(error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
|
||||
t)
|
||||
|
||||
;; v0.7.2 — Undo/Redo
|
||||
(defvar *undo-stack* nil
|
||||
"Ring buffer of pre-operation memory snapshots. Newest first, max 20.")
|
||||
(defvar *redo-stack* nil
|
||||
"Stack of snapshots saved during undo for redo. Max 20.")
|
||||
|
||||
(defun undo-snapshot ()
|
||||
"Save current memory state to the undo stack."
|
||||
(let ((snap (list :timestamp (get-universal-time)
|
||||
:data (memory-hash-table-copy *memory-store*))))
|
||||
(push snap *undo-stack*)
|
||||
(when (> (length *undo-stack*) 20)
|
||||
(setf *undo-stack* (subseq *undo-stack* 0 20)))))
|
||||
|
||||
(defun undo (&optional source)
|
||||
"Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty."
|
||||
(declare (ignore source))
|
||||
(if *undo-stack*
|
||||
(let ((snap (pop *undo-stack*)))
|
||||
(push (list :timestamp (get-universal-time)
|
||||
:data (memory-hash-table-copy *memory-store*))
|
||||
*redo-stack*)
|
||||
(when (> (length *redo-stack*) 20)
|
||||
(setf *redo-stack* (subseq *redo-stack* 0 20)))
|
||||
(setf *memory-store* (memory-hash-table-copy (getf snap :data)))
|
||||
(log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp))
|
||||
t)
|
||||
(progn (log-message "UNDO: No snapshots to undo") nil)))
|
||||
|
||||
(defun redo (&optional source)
|
||||
"Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty."
|
||||
(declare (ignore source))
|
||||
(if *redo-stack*
|
||||
(let ((snap (pop *redo-stack*)))
|
||||
(push (list :timestamp (get-universal-time)
|
||||
:data (memory-hash-table-copy *memory-store*))
|
||||
*undo-stack*)
|
||||
(when (> (length *undo-stack*) 20)
|
||||
(setf *undo-stack* (subseq *undo-stack* 0 20)))
|
||||
(setf *memory-store* (memory-hash-table-copy (getf snap :data)))
|
||||
(log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp))
|
||||
t)
|
||||
(progn (log-message "REDO: No snapshots to redo") nil)))
|
||||
#+end_src
|
||||
|
||||
** Merkle Audit
|
||||
#+begin_src lisp
|
||||
(defun audit-node (node-id)
|
||||
"Return audit info for a memory object by ID."
|
||||
(let ((obj (memory-object-get node-id)))
|
||||
(when obj
|
||||
(list :id node-id :type (memory-object-type obj)
|
||||
:version (memory-object-version obj)
|
||||
:hash (or (memory-object-hash obj) "(none)")
|
||||
:scope (memory-object-scope obj)))))
|
||||
|
||||
(defun audit-verify-hash ()
|
||||
"Count memory objects and report any with missing/empty hashes.
|
||||
Returns (total . missing-hashes)."
|
||||
(let ((total 0) (missing 0))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when obj
|
||||
(incf total)
|
||||
(let ((h (memory-object-hash obj)))
|
||||
(when (or (null h) (string= h ""))
|
||||
(incf missing)))))
|
||||
*memory-store*)
|
||||
(cons total missing)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Merkle hash is deterministic and consistent across independent AST ingestions.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
(test test-undo-snapshot-restore
|
||||
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
||||
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "x" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-redo-cycle
|
||||
"Contract v0.7.2: redo restores undone state."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "y" passepartout::*memory-store*) "world")
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "y" passepartout::*memory-store*)))
|
||||
(is (passepartout::redo))
|
||||
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-empty-stack-nil
|
||||
"Contract v0.7.2: undo returns nil on empty stack."
|
||||
(let ((orig-undo passepartout::*undo-stack*))
|
||||
(unwind-protect
|
||||
(progn (setf passepartout::*undo-stack* nil)
|
||||
(is (null (passepartout::undo))))
|
||||
(setf passepartout::*undo-stack* orig-undo))))
|
||||
|
||||
(test test-audit-node-found
|
||||
"Contract v0.7.2: audit-node returns info for existing object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "audit-1" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
||||
:version 1 :hash "abc123" :scope :memex))
|
||||
(let ((info (passepartout::audit-node "audit-1")))
|
||||
(is (not (null info)))
|
||||
(is (eq :HEADLINE (getf info :type)))
|
||||
(is (string= "abc123" (getf info :hash)))))
|
||||
|
||||
(test test-audit-node-not-found
|
||||
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
||||
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
||||
|
||||
(test test-audit-verify-hash
|
||||
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "a" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
||||
(let ((result (passepartout::audit-verify-hash)))
|
||||
(is (= 1 (car result)))
|
||||
(is (= 0 (cdr result)))))
|
||||
#+end_src
|
||||
380
org/core-package.org
Normal file
380
org/core-package.org
Normal file
@@ -0,0 +1,380 @@
|
||||
#+TITLE: Core: Package Definition (core-package.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :passepartout:core:defpackage:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-package.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
~package.lisp~ defines two things: the public API of the ~passepartout~ package (the export list), and the implementation of low-level utility functions and global state that don't belong in a specific pipeline stage or skill.
|
||||
|
||||
The export list is the contract between the harness and all skills. Every function exported here is accessible to every skill via ~use-package~. Adding a symbol here is an API commitment; removing one is a breaking change.
|
||||
|
||||
The implementation section includes:
|
||||
- ~proto-get~ — robust plist accessor used everywhere in the pipeline
|
||||
- Logging state (~*log-buffer*~, ~*log-lock*~) — bounded ring buffer for LLM context
|
||||
- Skill registry (~*skill-registry*~, ~defskill~) — all loaded skills live here
|
||||
- Cognitive tool registry (~*cognitive-tool-registry*~, ~def-cognitive-tool~, ~cognitive-tool-prompt~)
|
||||
- Telemetry tracking (~*telemetry-table*~, ~telemetry-track~) — performance metrics per skill
|
||||
- Debugger hook — replaces raw SBCL debugger with a friendly error message
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Definition and Export List
|
||||
The export list is organized by source module so a contributor can find
|
||||
where to add new exports:
|
||||
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; ── Core: Transport & Protocol ──
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:proto-get
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:register-actuator
|
||||
#:actuator-initialize
|
||||
#:action-dispatch
|
||||
|
||||
;; ── Core: Pipeline ──
|
||||
#:main
|
||||
#:log-message
|
||||
#:*log-buffer*
|
||||
#:*log-lock*
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
#:loop-gate-perceive
|
||||
#:act-gate
|
||||
#:loop-gate-act
|
||||
#:reason-gate
|
||||
#:loop-gate-reason
|
||||
#:cognitive-verify
|
||||
#:backend-cascade-call
|
||||
#:json-alist-to-plist
|
||||
#:stimulus-inject
|
||||
#:register-probabilistic-backend
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
|
||||
;; ── Core: Memory ──
|
||||
#:ingest-ast
|
||||
#:memory-object-get
|
||||
#:*memory-store*
|
||||
#:memory-object
|
||||
#:make-memory-object
|
||||
#:memory-object-id
|
||||
#:memory-object-type
|
||||
#:memory-object-attributes
|
||||
#:memory-object-parent-id
|
||||
#:memory-object-children
|
||||
#:memory-object-version
|
||||
#:memory-object-last-sync
|
||||
#:memory-object-vector
|
||||
#:memory-object-content
|
||||
#:memory-object-hash
|
||||
#:memory-object-scope
|
||||
#:memory-objects-by-attribute
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:undo-snapshot
|
||||
#:undo
|
||||
#:redo
|
||||
#:*undo-stack*
|
||||
#:*redo-stack*
|
||||
|
||||
;; ── Core: Context & Awareness ──
|
||||
#:context-get-system-logs
|
||||
#:context-assemble-global-awareness
|
||||
#:context-awareness-assemble
|
||||
#:context-query
|
||||
#:push-context
|
||||
#:pop-context
|
||||
#:current-context
|
||||
#:current-scope
|
||||
#:context-stack-depth
|
||||
#:context-save
|
||||
#:context-load
|
||||
#:focus-project
|
||||
#:focus-session
|
||||
#:focus-memex
|
||||
#:unfocus
|
||||
#:*scope-resolver*
|
||||
|
||||
;; ── Core: Skills Engine ──
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:skill-initialize-all
|
||||
#:load-skill-from-org
|
||||
#:lisp-syntax-validate
|
||||
|
||||
;; ── Core: Cognitive Tools ──
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tool-registry*
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:tool-read-only-p
|
||||
|
||||
;; ── Security: Dispatcher ──
|
||||
#:dispatcher-check-secret-path
|
||||
#:dispatcher-check-shell-safety
|
||||
#:dispatcher-check-privacy-tags
|
||||
#:dispatcher-check-network-exfil
|
||||
#:dispatcher-check
|
||||
#:dispatcher-gate
|
||||
#:wildcard-match
|
||||
|
||||
;; ── Security: HITL ──
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
|
||||
;; ── Security: Vault & Permissions ──
|
||||
#:*VAULT-MEMORY*
|
||||
#:vault-get
|
||||
#:vault-set
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:permission-get
|
||||
#:permission-set
|
||||
#:policy-compliance-check
|
||||
#:validator-protocol-check
|
||||
|
||||
;; ── Embedding ──
|
||||
#:*embedding-backend*
|
||||
#:*embedding-queue*
|
||||
#:*embedding-provider*
|
||||
#:embed-queue-object
|
||||
#:embed-object
|
||||
#:embed-all-pending
|
||||
#:embedding-backend-hashing
|
||||
#:embedding-backend-native
|
||||
#:embedding-native-load-model
|
||||
#:embedding-native-unload
|
||||
#:embedding-native-ensure-loaded
|
||||
#:embedding-native-get-dim
|
||||
#:embeddings-compute
|
||||
#:mark-vector-stale
|
||||
|
||||
;; ── Channels ──
|
||||
#:channel-cli-input
|
||||
#:gateway-start
|
||||
#:gateway-registry-initialize
|
||||
#:messaging-link
|
||||
#:messaging-unlink
|
||||
#:gateway-configured-p
|
||||
|
||||
;; ── Programming: Lisp ──
|
||||
#:lisp-validate
|
||||
#:lisp-structural-check
|
||||
#:lisp-syntactic-check
|
||||
#:lisp-semantic-check
|
||||
#:lisp-eval
|
||||
#:lisp-format
|
||||
#:lisp-list-definitions
|
||||
#:lisp-extract
|
||||
#:lisp-inject
|
||||
#:lisp-slurp
|
||||
|
||||
;; ── Programming: Org ──
|
||||
#:org-read-file
|
||||
#:org-write-file
|
||||
#:org-headline-add
|
||||
#:org-headline-find-by-id
|
||||
#:org-property-set
|
||||
#:org-todo-set
|
||||
#:org-id-generate
|
||||
#:org-id-format
|
||||
#:org-modify
|
||||
|
||||
;; ── Programming: Literate & REPL ──
|
||||
#:literate-tangle-sync-check
|
||||
#:literate-extract-lisp-blocks
|
||||
#:literate-block-balance-check
|
||||
#:repl-eval
|
||||
#:repl-inspect
|
||||
#:repl-list-vars
|
||||
|
||||
;; ── Symbolic ──
|
||||
#:archivist-create-note
|
||||
#:archivist-extract-headlines
|
||||
#:archivist-headline-to-filename
|
||||
|
||||
;; ── Diagnostics & Config ──
|
||||
#:diagnostics-run-all
|
||||
#:diagnostics-main
|
||||
#:diagnostics-dependencies-check
|
||||
#:diagnostics-env-check
|
||||
#:get-oc-config-dir
|
||||
#:run-setup-wizard
|
||||
|
||||
;; ── Providers ──
|
||||
#:register-provider
|
||||
#:provider-openai-request
|
||||
#:provider-config
|
||||
|
||||
;; ── Token Economics ──
|
||||
#:count-tokens
|
||||
#:model-token-ratio
|
||||
#:token-cost
|
||||
#:provider-token-cost
|
||||
#:cost-track-call
|
||||
#:cost-session-total
|
||||
#:cost-session-calls
|
||||
#:cost-by-provider
|
||||
#:cost-session-reset
|
||||
#:cost-format-budget-status
|
||||
#:cost-track-backend-call
|
||||
#:prompt-prefix-cached
|
||||
#:context-assemble-cached
|
||||
#:enforce-token-budget
|
||||
#:token-economics-initialize))
|
||||
#+end_src
|
||||
|
||||
** Package Implementation
|
||||
The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills.
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
*** Logging state
|
||||
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
|
||||
#+begin_src lisp
|
||||
(defvar *log-buffer* nil)
|
||||
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
||||
(defvar *log-limit* 100)
|
||||
#+end_src
|
||||
|
||||
*** Skill registry
|
||||
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
|
||||
#+begin_src lisp
|
||||
(defvar *skill-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
#+end_src
|
||||
|
||||
*** Skill telemetry
|
||||
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
|
||||
#+begin_src lisp
|
||||
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun telemetry-track (skill-name duration status)
|
||||
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *telemetry-table*) entry)))))
|
||||
#+end_src
|
||||
|
||||
*** Cognitive tool registry
|
||||
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt.
|
||||
#+begin_src lisp
|
||||
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body
|
||||
read-only-p)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body read-only-p)
|
||||
"Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body
|
||||
:read-only-p ,read-only-p)))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defun cognitive-tool-prompt ()
|
||||
"Serialises all registered tools into a prompt string for the LLM."
|
||||
(let ((descriptions nil))
|
||||
(maphash (lambda (k tool)
|
||||
(declare (ignore k))
|
||||
(push (format nil "- ~a: ~a~% Parameters: ~a~%"
|
||||
(cognitive-tool-name tool)
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool))
|
||||
descriptions))
|
||||
*cognitive-tool-registry*)
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt
|
||||
(defun generate-tool-belt-prompt ()
|
||||
(cognitive-tool-prompt))
|
||||
|
||||
(defun tool-read-only-p (name)
|
||||
"Returns T if the named cognitive tool is read-only, NIL otherwise."
|
||||
(let ((tool (gethash (string-downcase (string name)) *cognitive-tool-registry*)))
|
||||
(when tool
|
||||
(cognitive-tool-read-only-p tool))))
|
||||
#+end_src
|
||||
|
||||
*** Centralized logging (log-message)
|
||||
Thread-safe logging function that writes to both the ring buffer (for LLM context) and stdout (for the user). Bounded by ~*log-limit*~.
|
||||
#+begin_src lisp
|
||||
(defun log-message (msg &rest args)
|
||||
"Centralized, thread-safe logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*log-lock*)
|
||||
(push formatted-msg *log-buffer*)
|
||||
(when (> (length *log-buffer*) *log-limit*)
|
||||
(setq *log-buffer* (subseq *log-buffer* 0 *log-limit*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
#+end_src
|
||||
|
||||
*** Debugger hook
|
||||
Friendly error handler that replaces the raw SBCL debugger with a diagnostic message. This prevents the agent from entering the debugger on unhandled conditions.
|
||||
#+begin_src lisp
|
||||
(setf *debugger-hook* (lambda (condition hook)
|
||||
"Friendly error handler - shows diagnostic message instead of raw debugger."
|
||||
(declare (ignore hook))
|
||||
(format t "~%")
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: passepartout diagnostics~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(format t "Backtrace:~%")
|
||||
(sb-debug:print-backtrace :count 20 :stream *standard-output*)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
#+end_src
|
||||
289
org/core-perceive.org
Normal file
289
org/core-perceive.org
Normal file
@@ -0,0 +1,289 @@
|
||||
#+TITLE: Stage 1: Perceive (perceive.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:perceive:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-perceive.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Perceive stage is the sensory cortex of Passepartout. It receives raw stimuli from diverse sources — terminal input, Emacs buffers, Telegram messages, Signal chats, heartbeat clocks, shell command outputs — and normalizes them into a single Signal format that the rest of the pipeline can process.
|
||||
|
||||
Each source has its own format and protocol. The CLI sends raw text. Emacs sends AST diffs. Telegram sends JSON. Without normalization, every downstream component (Reason, Act) would need to understand every input format. With normalization:
|
||||
|
||||
1. The gateway layer (CLI, Emacs, Telegram, Signal) just sends raw messages
|
||||
2. Perceive transforms them into Signals regardless of origin
|
||||
3. Reason and Act work with a single, consistent plist format
|
||||
4. Adding a new gateway requires gateway code only — no changes to core
|
||||
|
||||
This is the "thin harness, fat skills" principle applied to input processing. The harness does the minimal normalization needed to produce a uniform Signal; the actual interpretation is left to skills.
|
||||
|
||||
** Why the Async/Sync Split?
|
||||
|
||||
Perceive handles two kinds of stimuli:
|
||||
- **Synchronous** (user input, chat messages) — these must be processed in order, one at a time, because each depends on the state left by the previous one
|
||||
- **Asynchronous** (heartbeats, background sensor readings, delegation results) — these can be processed in parallel because they don't depend on user intent
|
||||
|
||||
The `*loop-async-sensors*` list defines which sensor types are processed in dedicated threads. Everything else goes through the main synchronous pipeline.
|
||||
|
||||
The depth limit prevents runaway recursive loops. A signal that generates another signal that generates another signal can infinite-loop. If depth exceeds a threshold (10), the signal is silently dropped rather than processed. This is the metabolic loop's circuit breaker.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-gate-perceive signal): normalizes sensory input. Routes by
|
||||
sensor type (~:buffer-update~, ~:point-update~, ~:interrupt~,
|
||||
~:approval-required~) and signal type (~:EVENT~, ~:RESPONSE~).
|
||||
Sets ~:status :perceived~ on completion. Returns the signal.
|
||||
2. (perceive-gate signal): thin alias for ~loop-gate-perceive~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Interrupt Flag
|
||||
|
||||
A global interrupt flag that can be set by any signal. When set, the metabolic loop should stop processing and clean up. This is used for graceful shutdown: a SIGINT or /exit command sets the flag, and the loop exits at the next cycle boundary.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-interrupt* nil)
|
||||
#+end_src
|
||||
|
||||
** Scope Resolver
|
||||
|
||||
A hook for the context-manager skill to register its ~current-scope~
|
||||
function. When set, the perceive gate passes the current context scope
|
||||
to ~ingest-ast~ so ingested objects are tagged and queryable by scope.
|
||||
Defaults to ~nil~ meaning all objects are ingested as ~:memex~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *scope-resolver* nil
|
||||
"If set, function returning current scope keyword. Used by perceive gate.")
|
||||
#+end_src
|
||||
|
||||
** Sensor Configuration
|
||||
|
||||
~*loop-async-sensors*~ lists the sensor types that should be processed in their own threads. Currently, ~:chat-message~, ~:delegation~, and ~:user-command~ are async because they don't block the main reasoning loop — the agent can process a Telegram message while waiting for the user's next input.
|
||||
|
||||
~*loop-focus-id*~ tracks what the user is currently looking at in Emacs. When the user moves their cursor to a different Org headline, the buffer-update signal updates this ID. The Reason stage uses it to build the foveal-peripheral context model: the current headline gets full detail, everything else gets a skeletal outline.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
#+end_src
|
||||
** *loop-focus-id*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
#+end_src
|
||||
|
||||
** Pre-Reason Handler Registry
|
||||
|
||||
Skills register handlers for custom sensors here. When a signal arrives
|
||||
with a registered sensor, the handler is called in the perceive gate,
|
||||
before the signal reaches the LLM. The handler receives the full signal
|
||||
and returns T if the signal was consumed (don't continue to reason)
|
||||
or nil if processing should proceed normally.
|
||||
|
||||
*** Pre-Reason Handler Hash Table
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *pre-reason-handlers* (make-hash-table :test 'eq)
|
||||
"Pre-reason handler registry: sensor keyword → handler function.")
|
||||
#+end_src
|
||||
|
||||
*** register-pre-reason-handler
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun register-pre-reason-handler (sensor fn)
|
||||
"Registers FN to handle signals with SENSOR in the perceive gate.
|
||||
FN receives (signal) and returns T if consumed, nil to continue."
|
||||
(setf (gethash sensor *pre-reason-handlers*) fn))
|
||||
#+end_src
|
||||
|
||||
** Stimulus Injection (stimulus-inject)
|
||||
|
||||
This is the entry point that gateways call to send a message into the cognitive pipeline. It sets metadata (source, session ID, reply stream), decides whether the stimulus should be processed synchronously or on a background thread, and wraps the whole thing in error recovery so that no single bad stimulus can crash the system.
|
||||
|
||||
The error recovery uses Common Lisp's restart system. If any error occurs during processing, a `skip-event` restart is available. The handler displays the error, then invokes `skip-event` which drops the stimulus and continues. This is the "fail open" safety model — better to drop one message than to crash the entire agent.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun stimulus-inject (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p)
|
||||
(member sensor *loop-async-sensors*))))
|
||||
|
||||
(unless meta
|
||||
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
|
||||
(when stream
|
||||
(setf (getf meta :reply-stream) stream))
|
||||
|
||||
(setf (getf raw-message :meta) meta)
|
||||
(setf (getf raw-message :depth) depth)
|
||||
|
||||
(if async-p
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case (process-signal raw-message)
|
||||
(skip-event () nil)))
|
||||
:name "passepartout-async-task")
|
||||
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(log-message "SYSTEM ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event ()
|
||||
(log-message "SYSTEM RECOVERY: Stimulus dropped."))))))
|
||||
#+end_src
|
||||
|
||||
** Perceive Gate (loop-gate-perceive)
|
||||
|
||||
The perceive gate is the first stage of the metabolic pipeline. It receives a normalized signal and routes it based on the event type:
|
||||
|
||||
- ~:EVENT~ with ~:buffer-update~ — an Emacs buffer changed (new Org headline created, text edited). The change is ingested into memory so the agent has the latest state.
|
||||
- ~:EVENT~ with ~:point-update~ — the user moved their cursor to a different headline. The foveal focus is updated, and the node at the cursor is ingested at higher priority.
|
||||
- ~:EVENT~ with ~:interrupt~ — the user requested an interrupt. The interrupt flag is set.
|
||||
- ~:RESPONSE~ — an action completed. The gate logs the result status.
|
||||
|
||||
All signals get tagged with their processing stage (`:status :perceived`) and the current foveal focus before being passed to the Reason stage.
|
||||
|
||||
*** loop-gate-perceive
|
||||
|
||||
The main perceive pipeline stage.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-perceive (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
;; HITL: intercept approval/denial commands before LLM processing
|
||||
(when (and (eq sensor :user-input)
|
||||
(stringp (getf payload :text)))
|
||||
(let ((text (getf payload :text)))
|
||||
(when (ignore-errors (hitl-handle-message text (getf meta :source)))
|
||||
(log-message "GATE [Perceive]: HITL command processed — ~a" text)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
;; Pre-reason handlers: dispatch custom sensors to registered skill handlers
|
||||
(let ((handler (gethash sensor *pre-reason-handlers*)))
|
||||
(when handler
|
||||
(when (funcall handler signal)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
|
||||
(log-message "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))
|
||||
;; v0.7.2 undo/redo
|
||||
(:undo
|
||||
(log-message "GATE [Perceive]: undo requested")
|
||||
(undo "perceive"))
|
||||
(:redo
|
||||
(log-message "GATE [Perceive]: redo requested")
|
||||
(redo "perceive"))
|
||||
;; HITL: re-injected approved action from dispatcher-approvals-process
|
||||
(:approval-required
|
||||
(when (getf payload :approved)
|
||||
(log-message "GATE [Perceive]: Approved Flight Plan re-injected")
|
||||
(setf (getf signal :approved) t)
|
||||
(setf (getf signal :approved-action) (getf payload :action))))
|
||||
;; Default sensor: pass through without requiring user-input processing
|
||||
(otherwise
|
||||
(log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor))))
|
||||
((eq type :RESPONSE)
|
||||
(log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *loop-focus-id*)
|
||||
signal))
|
||||
#+end_src
|
||||
|
||||
*** perceive-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~perceive-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-perceive~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun perceive-gate (signal)
|
||||
(loop-gate-perceive signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the perceive gate correctly ingests AST nodes into memory and that the depth limiter prevents runaway recursive signals.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
#+end_src
|
||||
436
org/core-pipeline.org
Normal file
436
org/core-pipeline.org
Normal file
@@ -0,0 +1,436 @@
|
||||
#+TITLE: The Metabolic Loop (loop.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:loop:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-pipeline.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Metabolic Loop is the cranial nerve reflex of Passepartout. While skills provide specialized intelligence, the loop provides the fundamental rhythm of existence: the continuous processing of signals from perception through cognition to action.
|
||||
|
||||
Every signal flows through three stages:
|
||||
1. **Perceive** — normalize raw input into a standard Signal format
|
||||
2. **Reason** — think (LLM) then verify (deterministic gates)
|
||||
3. **Act** — dispatch the approved action to the appropriate actuator
|
||||
|
||||
If a stage produces a new signal (e.g., the Act stage produces a tool-output event), that signal feeds back into Perceive and the loop continues. This is how the agent has multi-step conversations: each LLM response produces an action, which produces a tool output, which feeds back as a new perception, which triggers the next reasoning cycle.
|
||||
|
||||
** Why Separate Stages?
|
||||
|
||||
A single function that called the LLM, checked safety, and executed the result would be simpler to write. But it would be impossible to:
|
||||
- Test each stage independently (a bug in the LLM call would block safety testing)
|
||||
- Insert new stages between P and R or R and A (adding consensus means adding a gate in the middle)
|
||||
- Recover from failures mid-pipeline (an LLM timeout shouldn't prevent safety checks on the next cycle)
|
||||
|
||||
The stage separation is the functional equivalent of the "thin harness" principle: each stage is a pure function that transforms a signal. The loop is the composition of these functions.
|
||||
|
||||
** Why the Depth Limit?
|
||||
|
||||
A signal that generates another signal that generates another signal can infinite-loop. The depth limit (max 10) prevents this. If depth exceeds 10, the signal is silently dropped. This is the metabolic loop's circuit breaker.
|
||||
|
||||
The three-tier error recovery model, now backed by a condition hierarchy
|
||||
that skills can hook into via ~handler-bind~:
|
||||
|
||||
1. **Transient errors** (tool failures, network timeouts) — recoverable, generate a :loop-error signal at higher depth for retry. Use the ~skip-signal~ or ~use-fallback~ restart.
|
||||
2. **Critical errors** (undefined functions, malformed data) — require memory rollback to the last snapshot.
|
||||
3. **Recursive loops** (signals generating more signals indefinitely) — depth limit enforcement.
|
||||
|
||||
Condition types available for structured error handling:
|
||||
- ~pipeline-error~ — any Perceive→Reason→Act failure
|
||||
- ~llm-error~ — provider timeout, cascade exhaustion, API error (slots: provider, cascade, attempt-count)
|
||||
- ~gate-error~ — dispatcher blocked a proposed action (slots: gate-name, rejected-action)
|
||||
- ~budget-error~ — session cap exceeded (slots: remaining, requested)
|
||||
- ~protocol-error~ — malformed message or framing failure
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-process signal): the full pipeline loop — Perceive → Reason
|
||||
→ Act. Enforces depth limit (10). Catches errors with rollback and
|
||||
~:loop-error~ re-injection on non-terminal errors below depth 2.
|
||||
Establishes restart options: ~skip-signal~ (drop the event),
|
||||
~use-fallback text~ (inject canned response), ~abort-pipeline~
|
||||
(clean exit). Skills can invoke these restarts from ~handler-bind~
|
||||
clauses on the condition hierarchy.
|
||||
2. (process-signal signal): thin alias for ~loop-process~.
|
||||
3. (diagnostics-startup-run): runs health check on startup, sets
|
||||
~*system-health*~ to ~:healthy~, ~:degraded~, or ~:unhealthy~.
|
||||
4. *passepartout-error* condition hierarchy: ~pipeline-error~,
|
||||
~llm-error~ (provider, cascade, attempt-count slots), ~gate-error~
|
||||
(gate-name, rejected-action slots), ~budget-error~ (remaining,
|
||||
requested slots), ~protocol-error~ (raw-message slot). All carry a
|
||||
~:message~ string via the root ~passepartout-error~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Error Condition Hierarchy
|
||||
|
||||
The pipeline defines a condition hierarchy so callers can distinguish
|
||||
failure modes without inspecting raw error strings. Every pipeline
|
||||
condition carries structured slots for telemetry and restart selection.
|
||||
|
||||
Skills install ~handler-bind~ for specific conditions (e.g., a provider
|
||||
health monitor that records ~llm-error~ failures per backend). The
|
||||
restarts registered in ~loop-process~ enable structured recovery:
|
||||
skip the signal, retry with a modified prompt, inject a fallback
|
||||
response, or abort the cycle.
|
||||
|
||||
#+begin_src lisp
|
||||
(define-condition passepartout-error (error)
|
||||
((message :initarg :message :reader error-message))
|
||||
(:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c))))
|
||||
(:documentation "Root of the pipeline error hierarchy."))
|
||||
|
||||
(define-condition pipeline-error (passepartout-error)
|
||||
((signal :initarg :signal :reader pipeline-error-signal :initform nil))
|
||||
(:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c))))
|
||||
(:documentation "Any error during the Perceive→Reason→Act cycle."))
|
||||
|
||||
(define-condition llm-error (pipeline-error)
|
||||
((provider :initarg :provider :reader llm-error-provider)
|
||||
(cascade :initarg :cascade :reader llm-error-cascade :initform nil)
|
||||
(attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0))
|
||||
(:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c))))
|
||||
(:documentation "LLM provider failure: timeout, cascade exhaustion, or API error."))
|
||||
|
||||
(define-condition gate-error (pipeline-error)
|
||||
((gate-name :initarg :gate-name :reader gate-error-gate-name)
|
||||
(rejected-action :initarg :rejected-action :reader gate-error-rejected-action))
|
||||
(:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c))))
|
||||
(:documentation "Deterministic gate blocked a proposed action."))
|
||||
|
||||
(define-condition budget-error (pipeline-error)
|
||||
((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0)
|
||||
(requested :initarg :requested :reader budget-error-requested :initform 0.0))
|
||||
(:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c))))
|
||||
(:documentation "Session budget cap has been reached."))
|
||||
|
||||
(define-condition protocol-error (passepartout-error)
|
||||
((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil))
|
||||
(:report (lambda (c s) (format s "Protocol error: ~a" (error-message c))))
|
||||
(:documentation "Malformed message, framing failure, or schema violation."))
|
||||
#+end_src
|
||||
|
||||
** Global Interrupt State
|
||||
|
||||
Thread-safe interrupt flag. The ~*loop-interrupt-lock*~ mutex protects access so that the signal handler and the main loop don't race on shutdown.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.")
|
||||
|
||||
#+end_src
|
||||
** *loop-interrupt-lock*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.")
|
||||
|
||||
#+end_src
|
||||
** *heartbeat-thread*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Core Engine (loop-process)
|
||||
|
||||
The entry point to the metabolic pipeline. Each cycle runs Perceive → Reason → Act. If Act produces feedback (a new signal), the loop continues with that signal at the same depth.
|
||||
|
||||
The function handles four failure modes:
|
||||
- **Depth exceeded**: signal dropped, nil returned
|
||||
- **Interrupt flag**: graceful shutdown, nil returned
|
||||
- **Handler error**: caught by handler-case, logged, and depending on the sensor type and depth:
|
||||
- Normal errors at low depth → memory rollback + retry as :loop-error
|
||||
- :loop-error and :tool-error at any depth → dropped (avoids infinite retry loops)
|
||||
- High-depth errors (depth > 2) → dropped (avoids cascading failures)
|
||||
- **Unhandled error**: the handler-case catches everything, preventing any single bad signal from crashing the agent
|
||||
|
||||
*** loop-process
|
||||
|
||||
The main pipeline entry point.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-process (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10)
|
||||
(log-message "METABOLISM ERROR: Max recursion depth reached.")
|
||||
(return nil))
|
||||
|
||||
(when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*)
|
||||
(log-message "METABOLISM: Interrupted by shutdown signal.")
|
||||
(return nil))
|
||||
|
||||
(restart-case
|
||||
(handler-bind
|
||||
((pipeline-error (lambda (c)
|
||||
(log-message "PIPELINE ERROR: ~a" (error-message c)))))
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))
|
||||
(skip-signal ()
|
||||
:report "Drop the current signal and continue the loop."
|
||||
(setf current-signal nil))
|
||||
(use-fallback (text)
|
||||
:report "Inject a canned response instead of the LLM result."
|
||||
(setf current-signal
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message text :depth depth))))
|
||||
(abort-pipeline ()
|
||||
:report "Terminate the cognitive cycle cleanly."
|
||||
(return nil)))))))
|
||||
#+end_src
|
||||
|
||||
*** process-signal (backward-compatibility alias)
|
||||
|
||||
The pipeline entry point was originally named ~process-signal~. Code
|
||||
that still uses the old name can call this alias. New code should call
|
||||
~loop-process~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun process-signal (signal)
|
||||
(loop-process signal))
|
||||
#+end_src
|
||||
|
||||
** Heartbeat Mechanism
|
||||
|
||||
The heartbeat is a background thread that fires every N seconds (configurable via ~HEARTBEAT_INTERVAL~ env var, default 60). On each tick, it:
|
||||
|
||||
1. Increments the save counter and saves memory to disk when the counter exceeds the auto-save interval (default 300s)
|
||||
2. Injects a ~:heartbeat~ signal into the pipeline
|
||||
|
||||
The heartbeat signal is how background skills (Gardener, Scribe) get triggered without user input. These skills have triggers that match ~:sensor :heartbeat~ and run maintenance tasks during idle cycles.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-auto-save-interval* 300)
|
||||
#+end_src
|
||||
** *heartbeat-save-counter*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
#+end_src
|
||||
** heartbeat-start
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun heartbeat-start ()
|
||||
"Starts the background heartbeat thread."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *memory-auto-save-interval*)))
|
||||
(setf *memory-auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "passepartout-heartbeat"))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Shutdown Save Flag
|
||||
|
||||
Controls whether memory is saved on shutdown. Useful for testing when you want a clean state on next boot.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
#+end_src
|
||||
|
||||
** System Health Status
|
||||
|
||||
Used by the health check protocol and the daemon's status endpoint. Set by ~diagnostics-startup-run~ during boot.
|
||||
|
||||
- ~:healthy~ — all checks passed
|
||||
- ~:degraded~ — checks found issues but the daemon can still run
|
||||
- ~:unhealthy~ — checks failed, the daemon may not function correctly
|
||||
- ~:unknown~ — health check hasn't run yet
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *system-health* :unknown
|
||||
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
|
||||
|
||||
#+end_src
|
||||
** *health-check-ran*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *health-check-ran* nil
|
||||
"Flag indicating if initial health check has completed.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Proactive Doctor
|
||||
|
||||
Runs the doctor diagnostics automatically at startup. If the doctor finds issues (missing dependencies, misconfigured providers), it prints a diagnostic message but does NOT block the daemon from starting. The user can see the issues and run ~passepartout doctor --fix~ to repair.
|
||||
|
||||
This is the "fail open" principle applied to boot: the system should start even with problems, not refuse to start until everything is perfect.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-startup-run ()
|
||||
"Runs the doctor diagnostics on startup. Returns health status."
|
||||
(format t "~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " DOCTOR: Running Startup Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'diagnostics-run-all)
|
||||
(let ((result (diagnostics-run-all :auto-install nil)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
(setf *system-health* :healthy)
|
||||
(format t "DAEMON: Health check passed. Starting services.~%"))
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'passepartout diagnostics' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DIAGNOSTICS ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
#+end_src
|
||||
|
||||
** Main Entry Point (main)
|
||||
|
||||
The top-level entry point. Called by ~passepartout daemon~ and ~passepartout tui~.
|
||||
|
||||
Boot sequence:
|
||||
1. Load environment variables from ~.config/passepartout/.env~
|
||||
2. Load persisted memory state from disk
|
||||
3. Register core actuators (:system, :tool, :tui)
|
||||
4. Initialize all skills (tangging .lisp or loading from XDG)
|
||||
5. Run the proactive health check
|
||||
6. Start the heartbeat thread (background maintenance)
|
||||
7. Start the TCP daemon (listens for CLI/TUI connections)
|
||||
8. Install the SIGINT handler (graceful shutdown on Ctrl+C)
|
||||
9. Enter the idle sleep loop (wakes on interrupt)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun main ()
|
||||
"Entry point for Passepartout. Initializes the system and enters idle loop."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".config/passepartout/.env" (uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(actuator-initialize)
|
||||
(skill-initialize-all)
|
||||
|
||||
;; Run proactive diagnostics before starting services
|
||||
(diagnostics-startup-run)
|
||||
|
||||
(when (fboundp 'events-start-heartbeat)
|
||||
(events-start-heartbeat))
|
||||
(handler-case (start-daemon)
|
||||
(error (c)
|
||||
(log-message "DAEMON: Failed to start — ~a" c)
|
||||
(format *error-output* "~&DAEMON: Failed to start — ~a~%" c)))
|
||||
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(log-message "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
|
||||
(loop
|
||||
(when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*)
|
||||
(log-message "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the immune system (error handling) correctly catches and reports errors from the cognitive pipeline.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (if (fboundp 'passepartout::context-get-system-logs)
|
||||
(passepartout:context-get-system-logs 20)
|
||||
nil)))
|
||||
(is (or (null logs) ; no log service available — degraded but not broken
|
||||
(not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
737
org/core-reason.org
Normal file
737
org/core-reason.org
Normal file
@@ -0,0 +1,737 @@
|
||||
#+TITLE: Stage 2: Reason (reason.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:reason:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-reason.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Reason stage is the cognitive heart of Passepartout. It takes a normalized signal from Perceive and produces an approved action for Act. This is where the two engines — probabilistic (LLM) and deterministic (Lisp logic) — collaborate.
|
||||
|
||||
The design is shaped by one non-negotiable constraint: **the LLM must never touch the actuators directly.** Every action the LLM proposes must pass through a deterministic verification gate that has the final say. This is what separates Passepartout from every other AI agent: the creative brain suggests, but the logical brain decides.
|
||||
|
||||
** The Probabilistic-Deterministic Split
|
||||
|
||||
An LLM is a statistical engine. Given enough context, it is remarkably good at translation, generation, and pattern matching. But it cannot be trusted with authority because hallucination is a *fundamental property* of probabilistic inference — the model generates the most likely continuation, not the correct one.
|
||||
|
||||
The deterministic engine addresses this by being what the probabilistic engine is not: mathematically rigorous, formally verifiable, and incapable of hallucination by design. It operates on explicit symbolic representations — lists, property lists, knowledge graphs — not on floating-point activations. When it evaluates a path confinement check, it returns true or false, not a probability distribution.
|
||||
|
||||
The division of labor is architectural:
|
||||
- The LLM handles the fuzzy interface between human language and structured representation
|
||||
- The deterministic engine receives those structured representations and evaluates them against formal invariants
|
||||
- The LLM never reads a file, never executes a command, never modifies memory — it generates proposals
|
||||
|
||||
This separation is the source of Passepartout's safety guarantee. Other agents add "guardrails" as an afterthought — a layer of filtering around a dangerous core. Passepartout makes the division explicit.
|
||||
|
||||
** Why Plists for Communication?
|
||||
|
||||
Every message in the Reason pipeline is a property list (plist):
|
||||
|
||||
(TYPE :REQUEST TARGET :CLI PAYLOAD (ACTION :MESSAGE TEXT "Hello"))
|
||||
|
||||
A plist is simultaneously:
|
||||
- Human-readable text
|
||||
- Machine-parseable data structure
|
||||
- Executable Lisp code
|
||||
|
||||
This is not a cosmetic choice. It means the reasoning pipeline can generate, modify, and execute its own communication protocol without external parsing libraries. There is no JSON encoder, no schema validator, no serialization layer between the two engines. They speak the same language because they *are* the same language.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (cognitive-verify proposed-action context): runs all registered
|
||||
deterministic gates sorted by priority. Returns a rejection plist
|
||||
(~:LOG~ or ~:EVENT~) if any gate blocks the action, an
|
||||
~:approval-required~ event if a gate requires HITL, or the action
|
||||
(potentially modified) if it passes.
|
||||
2. (loop-gate-reason signal): the full reason pipeline — only processes
|
||||
~:user-input~ and ~:chat-message~ sensors. Runs ~think~ to generate
|
||||
a candidate, then ~cognitive-verify~ to gate it. Retries up to 3
|
||||
times on rejection. Sets ~:status :reasoned~ on completion.
|
||||
3. (reason-gate signal): thin alias for ~loop-gate-reason~.
|
||||
4. (backend-cascade-call prompt): iterates ~*provider-cascade*~ calling
|
||||
each backend's handler until one succeeds. Returns the LLM content
|
||||
string, or a ~:LOG~ failure if all backends are exhausted.
|
||||
5. (json-alist-to-plist alist): converts a JSON alist (from
|
||||
~cl-json:decode-json-from-string~) to a keyword-prefixed plist.
|
||||
String keys → upcased keywords. Nested alists recurse into plists.
|
||||
JSON arrays (lists whose first element is not a cons) pass through.
|
||||
Scalars and nil pass through.
|
||||
6. (think-assemble-prompt context): returns three values —
|
||||
~system-prompt~ (the full prompt string), ~raw-prompt~ (user text or
|
||||
skill-generated), and ~reply-stream~ (for streaming responses).
|
||||
Handles all conditional assembly paths: TIME section, CONFIG section,
|
||||
IDENTITY (assistant name + identity file + standing mandates +
|
||||
reflection feedback), TOOLS, CONTEXT, LOGS. Gracefully degrades when
|
||||
awareness or token-economics skills are not loaded.
|
||||
7. (think-call-llm raw-prompt system-prompt reply-stream context): calls
|
||||
the LLM. Checks session budget exhaustion before dispatching
|
||||
(v0.5.0 deferred, ~fboundp~-guarded). Uses streaming
|
||||
(~cascade-stream~) when reply-stream is non-nil and the streaming
|
||||
module is loaded; falls back to ~backend-cascade-call~ otherwise.
|
||||
Returns the raw thought (string or plist with ~:tool-calls~) or
|
||||
a budget-exhaustion message.
|
||||
8. (think-parse-response thought): parses the LLM response into an action
|
||||
plist. Handles three paths: structured ~:tool-calls~ (convert JSON args
|
||||
to plist via ~json-alist-to-plist~), raw S-expression text (parse with
|
||||
~*read-eval* nil~, normalize keywords), and plain text (wrap as
|
||||
~:MESSAGE~ action). Tracks cost via ~cost-track-backend-call~ when
|
||||
available. Guarantees a valid plist for any input.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Probabilistic Backend Registry
|
||||
|
||||
~*probabilistic-backends*~ is a hash table mapping provider keywords to
|
||||
their handler functions. Populated by ~register-probabilistic-backend~.
|
||||
Skills like system-model-provider register into this table at boot time.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
"Maps provider keyword → handler function (prompt system-prompt &key model).")
|
||||
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Register FN as the handler for provider NAME."
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
#+end_src
|
||||
|
||||
The probabilistic engine maintains three pieces of global state that control how LLM requests are dispatched:
|
||||
|
||||
~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus.
|
||||
|
||||
Providers register into ~*probabilistic-backends*~ (declared above) via ~register-probabilistic-backend~. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
|
||||
|
||||
** Provider Cascade
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *provider-cascade* nil)
|
||||
#+end_src
|
||||
|
||||
** Model Selector
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-selector* nil)
|
||||
#+end_src
|
||||
|
||||
** Consensus Toggle
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *consensus-enabled* nil)
|
||||
#+end_src
|
||||
|
||||
** Cascade Dispatch (backend-cascade-call)
|
||||
|
||||
Given a prompt, this function iterates through the provider cascade and calls each backend in order until one succeeds. A provider "succeeds" when it returns ~:status :success~ with content, or when it returns a plain string (the LLM's raw output).
|
||||
|
||||
The function has a fallback for every failure mode:
|
||||
- If a backend returns ~:status :error~, the cascade moves to the next provider
|
||||
- If a backend throws an exception, it is caught and logged, and the cascade moves on
|
||||
- If ALL backends are exhausted, a structured LOG message is returned saying "Neural Cascade Failure"
|
||||
|
||||
This is deliberately resilient. The system should never crash because an LLM provider is down. It should log the failure, try the next provider, and if all fail, return a diagnostic message that the deterministic engine can present to the user.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun backend-cascade-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil)
|
||||
tools)
|
||||
(let ((backends (or cascade *provider-cascade*))
|
||||
(result nil))
|
||||
(dolist (backend backends (or result
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (and *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(skip (eq model :skip))
|
||||
(r (unless skip
|
||||
(apply backend-fn
|
||||
(append (list prompt system-prompt :model model)
|
||||
(when tools (list :tools tools)))))))
|
||||
(when skip
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
||||
(cond ((and (listp r) (eq (getf r :status) :success))
|
||||
(let ((tool-calls (getf r :tool-calls)))
|
||||
(if tool-calls
|
||||
(return (list :status :success :tool-calls tool-calls))
|
||||
(progn
|
||||
(setf result (getf r :content))
|
||||
(return result)))))
|
||||
((stringp r)
|
||||
(setf result r)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf r :message))))))))))
|
||||
#+end_src
|
||||
|
||||
** Markdown Strip
|
||||
|
||||
The LLM might wrap its output in Markdown code fences (~```~). This function strips them before parsing. It also strips trailing/leading whitespace.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
#+end_src
|
||||
|
||||
** Normalize plist keywords
|
||||
|
||||
Lisp keywords are case-sensitive. The LLM might produce ~:payload~ or ~:PAYLOAD~ or ~:Payload~ depending on the model. This function normalizes all keyword keys to uppercase to ensure the deterministic engine receives consistent input.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun plist-keywords-normalize (plist)
|
||||
(when (listp plist)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
#+end_src
|
||||
|
||||
** Think: assemble context and call the LLM
|
||||
|
||||
This is the main entry point for the probabilistic engine. Every cognitive cycle goes through here.
|
||||
|
||||
The function handles several cases:
|
||||
- If a triggered skill provides a probabilistic prompt generator, that replaces the raw user input
|
||||
- If the previous proposal was rejected, the rejection trace is injected into the LLM's context so it can self-correct
|
||||
- Standing mandates from ~*standing-mandates*~ are injected into the IDENTITY section of the system prompt
|
||||
|
||||
The system prompt assembly order — identity (including mandates), tools, context, logs — is intentional: standing mandates appear early in IDENTITY so they set the behavioral frame before the model processes tools, context, and logs.
|
||||
|
||||
Token economics (v0.5.0): when ~token-economics~ is loaded, ~think()~ uses
|
||||
~context-assemble-cached~ (skips context assembly on heartbeat/delegation),
|
||||
~prompt-prefix-cached~ (avoids retransmitting IDENTITY+TOOLS), and
|
||||
~enforce-token-budget~ (trims over-budget prompts). Cost is tracked after
|
||||
each cascade call via ~cost-track-backend-call~. All four calls are
|
||||
~fboundp~-guarded — when the module is not loaded, behavior is unchanged.
|
||||
|
||||
~think()~ is the orchestrator that composes three sub-functions:
|
||||
|
||||
1. *think-assemble-prompt* — builds the full system prompt from context,
|
||||
awareness, logs, identity, standing mandates, and tool belt.
|
||||
2. *think-call-llm* — dispatches to the LLM (streaming or batch cascade).
|
||||
3. *think-parse-response* — converts the LLM's output to an action plist,
|
||||
handling structured tool-calls, raw S-expressions, and plain text.
|
||||
|
||||
The orchestrator snapshots memory, calls the three phases in sequence,
|
||||
and returns the action plist that flows into ~cognitive-verify~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
;; v0.7.2: live config section for system prompt
|
||||
(defun assemble-config-section ()
|
||||
"Build the CONFIG section of the system prompt from live state."
|
||||
(let ((provider-names "")
|
||||
(context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
|
||||
(tokenizer-context-limit (symbol-value '*tokenizer-provider*))
|
||||
8192))
|
||||
(gate-count 10)
|
||||
(rules-count 0))
|
||||
(when (boundp '*provider-cascade*)
|
||||
(setf provider-names
|
||||
(format nil "~{~a~^, ~}"
|
||||
(mapcar (lambda (p)
|
||||
(handler-case (or (getf p :model) (getf p :provider) "")
|
||||
(error () (princ-to-string p))))
|
||||
(symbol-value '*provider-cascade*)))))
|
||||
(when (boundp '*hitl-pending*)
|
||||
(setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
|
||||
(format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
|
||||
(if (string= provider-names "") "default" provider-names)
|
||||
context-window gate-count rules-count)))
|
||||
|
||||
(defun think-assemble-prompt (context)
|
||||
"Phase 2-3 of the metabolic cycle: context + system prompt assembly.
|
||||
Returns three values: system-prompt, raw-prompt, reply-stream."
|
||||
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
|
||||
(active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(reply-stream (proto-get context :reply-stream))
|
||||
(global-context (if (fboundp 'context-assemble-cached)
|
||||
(context-assemble-cached context sensor)
|
||||
(if (fboundp 'context-assemble-global-awareness)
|
||||
(context-assemble-global-awareness)
|
||||
"[Awareness skill not loaded]")))
|
||||
(system-logs (if (fboundp 'context-get-system-logs)
|
||||
(context-get-system-logs)
|
||||
"[No system logs available]"))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
||||
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
||||
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(reflection-feedback (if rejection-trace
|
||||
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
||||
""))
|
||||
(standing-mandates-text (let ((out ""))
|
||||
(dolist (fn *standing-mandates*)
|
||||
(let ((text (ignore-errors (funcall fn context))))
|
||||
(when (and text (stringp text) (> (length text) 0))
|
||||
(setf out (concatenate 'string out text (string #\Newline))))))
|
||||
(when (> (length out) 0) out)))
|
||||
(identity-content (if (fboundp 'agent-identity)
|
||||
(agent-identity)
|
||||
""))
|
||||
(config-section (if (fboundp 'assemble-config-section)
|
||||
(assemble-config-section)
|
||||
""))
|
||||
(time-section (if (fboundp 'sensor-time-duration)
|
||||
(format-time-for-llm
|
||||
:session-duration-seconds (funcall (symbol-function 'session-duration)))
|
||||
(if (fboundp 'format-time-for-llm)
|
||||
(format-time-for-llm)
|
||||
"")))
|
||||
(system-prompt (if (fboundp 'prompt-prefix-cached)
|
||||
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
|
||||
reflection-feedback
|
||||
standing-mandates-text tool-belt)))
|
||||
(if (fboundp 'enforce-token-budget)
|
||||
(multiple-value-bind (pfx ctxt logs _ mandates)
|
||||
(enforce-token-budget prefix global-context system-logs
|
||||
raw-prompt standing-mandates-text)
|
||||
(declare (ignore _))
|
||||
(setf standing-mandates-text mandates)
|
||||
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
||||
time-section config-section pfx (or ctxt "") logs))
|
||||
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
||||
time-section config-section prefix (or global-context "") system-logs)))
|
||||
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
||||
time-section config-section
|
||||
assistant-name identity-content reflection-feedback
|
||||
(if standing-mandates-text
|
||||
(concatenate 'string (string #\Newline) standing-mandates-text)
|
||||
"")
|
||||
tool-belt (or global-context "") system-logs))))
|
||||
(values system-prompt raw-prompt reply-stream)))
|
||||
|
||||
(defun think-call-llm (raw-prompt system-prompt reply-stream context)
|
||||
"Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade.
|
||||
Returns the raw LLM response (string or plist with :tool-calls)."
|
||||
;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted
|
||||
(when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p))
|
||||
(return-from think-call-llm (budget-exhaustion-message)))
|
||||
(if (and reply-stream (fboundp 'cascade-stream))
|
||||
(let ((acc (make-string-output-stream)))
|
||||
(funcall 'cascade-stream raw-prompt system-prompt
|
||||
(lambda (delta)
|
||||
(when reply-stream
|
||||
(format reply-stream "~a"
|
||||
(frame-message (list :type :stream-chunk
|
||||
:payload (list :text delta))))
|
||||
(finish-output reply-stream))
|
||||
(write-string delta acc)))
|
||||
(get-output-stream-string acc))
|
||||
(backend-cascade-call raw-prompt
|
||||
:system-prompt system-prompt
|
||||
:context context)))
|
||||
|
||||
(defun think-parse-response (thought)
|
||||
"Phases 5-7 of the metabolic cycle: cost tracking + response parsing.
|
||||
Returns an action plist ready for cognitive-verify."
|
||||
(let ((tool-calls (and (listp thought) (getf thought :tool-calls))))
|
||||
(when (and (fboundp 'cost-track-backend-call)
|
||||
(stringp thought)
|
||||
(or (null tool-calls)))
|
||||
(ignore-errors
|
||||
(cost-track-backend-call (first *provider-cascade*)
|
||||
thought)))
|
||||
(if tool-calls
|
||||
(let* ((first-call (car tool-calls))
|
||||
(tool-name (getf first-call :name))
|
||||
(args (getf first-call :arguments))
|
||||
(args-plist (json-alist-to-plist args)))
|
||||
(list :TYPE :REQUEST
|
||||
:PAYLOAD (list* :TOOL tool-name
|
||||
:ARGS args-plist
|
||||
:EXPLANATION "Generated by function-calling engine.")))
|
||||
(let* ((cleaned (if (and (listp thought) (getf thought :type))
|
||||
(format nil "~a" (getf (getf thought :payload) :text))
|
||||
(markdown-strip thought))))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0)
|
||||
(or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
|
||||
(if (listp parsed)
|
||||
(let ((normalized (plist-keywords-normalize parsed)))
|
||||
(let ((payload (proto-get normalized :payload)))
|
||||
(if (and payload (proto-get payload :explanation))
|
||||
normalized
|
||||
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
|
||||
(if (listp payload) payload nil))))
|
||||
(list* :PAYLOAD new-payload
|
||||
(loop for (k v) on normalized by #'cddr
|
||||
unless (eq k :PAYLOAD)
|
||||
collect k collect v))))))
|
||||
(list :TYPE :REQUEST :PAYLOAD
|
||||
(list :ACTION :MESSAGE :TEXT cleaned
|
||||
:EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error ()
|
||||
(list :TYPE :REQUEST :PAYLOAD
|
||||
(list :ACTION :MESSAGE :TEXT cleaned
|
||||
:EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD
|
||||
(list :ACTION :MESSAGE
|
||||
:TEXT (if (stringp cleaned) cleaned "No response")
|
||||
:EXPLANATION "Generated by the Probabilistic engine.")))))))
|
||||
|
||||
(defun think (context)
|
||||
"The probabilistic reasoning engine — orchestrates prompt assembly, LLM call,
|
||||
and response parsing into an action plist for cognitive-verify."
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory))
|
||||
(multiple-value-bind (system-prompt raw-prompt reply-stream)
|
||||
(think-assemble-prompt context)
|
||||
(let ((thought (think-call-llm raw-prompt system-prompt reply-stream context)))
|
||||
(think-parse-response thought))))
|
||||
#+end_src
|
||||
|
||||
** JSON-to-Plist Conversion (json-alist-to-plist)
|
||||
|
||||
Converts a JSON alist as returned by ~cl-json:decode-json-from-string~ to a keyword-prefixed plist — the internal data format that ~cognitive-verify~ and the actuator layer expect. This is the boundary where the probabilistic layer's output format (JSON) meets the deterministic layer's input format (plists).
|
||||
|
||||
String keys are interned as upcased keywords (~"action" → :ACTION~). Nested alists recurse. JSON arrays (lists whose first element is an atom) pass through unchanged since the actuator layer handles list arguments natively.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun json-alist-to-plist (alist)
|
||||
"Convert a JSON alist to a keyword-prefixed plist."
|
||||
(when (listp alist)
|
||||
(loop for (key . value) in alist
|
||||
append (list (intern (string-upcase (string key)) :keyword)
|
||||
(if (listp value)
|
||||
(if (consp (car value))
|
||||
(json-alist-to-plist value)
|
||||
value)
|
||||
value)))))
|
||||
#+end_src
|
||||
|
||||
** Deterministic Engine (cognitive-verify)
|
||||
|
||||
The deterministic engine is the strict guard. It receives a proposed action from the probabilistic engine and runs it through every registered deterministic gate, sorted by priority.
|
||||
|
||||
**Gate Trace (v0.4.0)**
|
||||
|
||||
As part of v0.4.0's TUI differentiator visualizations, ~cognitive-verify~ now accumulates a ~:gate-trace~ — a list of ~(:gate <name> :result <:passed|:blocked|:approval>)~ entries — as each deterministic gate processes the action. The trace is prepended to the result plist via ~list*~ and flows through the pipeline to the TUI actuator, which transmits it to the client.
|
||||
|
||||
This is Passepartout's permanent UX advantage: no competitor can ship a gate trace because none has deterministic gates to trace. Claude Code, OpenClaw, and Hermes Agent all use prompt-based guardrails where the safety decision is invisible. In Passepartout, the user sees exactly which nine safety gates ran, what each decided, and why — all at 0 LLM tokens.
|
||||
|
||||
Skills register deterministic gates via ~defskill~ with the ~:deterministic~ keyword. Each gate is a function that receives (action context) and returns either:
|
||||
- A modified action (the gate approves or adjusts the proposal)
|
||||
- A LOG or EVENT plist (the gate rejects the proposal with a reason)
|
||||
|
||||
Gates run in priority order, highest first. If any gate returns a LOG or EVENT, the proposal is rejected immediately and the rejection reason flows back to the probabilistic engine via the rejection trace. If all gates pass, the proposal is approved.
|
||||
|
||||
This architecture makes safety compositional: each skill adds one constraint. The dispatcher checks secrets. The policy checks explanations. The shell actuator checks destructive commands. No single skill needs to understand the full security model.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun cognitive-verify (proposed-action context)
|
||||
"Runs all registered deterministic gates against the proposed action,
|
||||
sorted by priority (highest first). Returns a rejection plist or the action."
|
||||
(let ((current-action (copy-tree proposed-action))
|
||||
(approval-needed nil)
|
||||
(approval-action nil)
|
||||
(gates nil)
|
||||
(gate-trace nil))
|
||||
;; Collect gates sorted by priority (highest first)
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
|
||||
*skill-registry*)
|
||||
(setf gates (sort gates #'> :key #'car))
|
||||
(dolist (gate-entry gates)
|
||||
(let* ((gate-name (cadr gate-entry))
|
||||
(result (funcall (cddr gate-entry) current-action context)))
|
||||
(cond
|
||||
((eq (getf result :level) :approval-required)
|
||||
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
|
||||
(let ((blocked-result (copy-list result)))
|
||||
(setf (getf blocked-result :gate-trace) (nreverse gate-trace))
|
||||
(return-from cognitive-verify blocked-result)))
|
||||
((and (listp result) result)
|
||||
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
|
||||
(setf current-action result)))))
|
||||
(if approval-needed
|
||||
(list :type :EVENT :level :approval-required
|
||||
:gate-trace (nreverse gate-trace)
|
||||
:payload (list :sensor :approval-required
|
||||
:action approval-action))
|
||||
(let ((passed-result (copy-tree current-action)))
|
||||
(setf (getf passed-result :gate-trace) (nreverse gate-trace))
|
||||
passed-result))))
|
||||
#+end_src
|
||||
|
||||
** Reason Gate (Stage 2)
|
||||
|
||||
The reason gate is the pipeline stage that orchestrates Think + Determine. It receives a signal, checks if it requires reasoning (only ~:user-input~ and ~:chat-message~ events do), and runs through the cognitive + verification loop.
|
||||
|
||||
The loop has retry logic: up to 3 attempts. If the deterministic engine rejects a proposal, the rejection reason is fed back into the next think call so the LLM can self-correct. This loop — propose, reject, correct, re-propose — is the core mechanism by which the agent improves its own output without human intervention.
|
||||
|
||||
The retry limit prevents infinite loops. If the LLM cannot produce a passable proposal within 3 attempts, the last rejection reason is attached to the signal and the acted pipeline sees a failed reasoning cycle.
|
||||
|
||||
*** loop-gate-reason
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-reason (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
||||
(return-from loop-gate-reason signal))
|
||||
(let ((retries 3)
|
||||
(current-signal (copy-tree signal))
|
||||
(last-rejection nil))
|
||||
(loop
|
||||
(when (<= retries 0)
|
||||
(setf (getf signal :approved-action) last-rejection)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
;; Approval-required is not a rejection — pass to act for Flight Plan
|
||||
(if (eq (getf verified :level) :approval-required)
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :requires-approval)
|
||||
(return signal))
|
||||
;; Hard rejection: retry with feedback
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal)))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
#+end_src
|
||||
|
||||
*** reason-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~reason-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-reason~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun reason-gate (signal)
|
||||
(loop-gate-reason signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))
|
||||
(is (getf result :gate-trace))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
(test test-read-eval-rce-blocked
|
||||
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* '(:mock-evil)))
|
||||
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
||||
(setf passepartout::*v031-rce-test* nil)
|
||||
(setf *read-eval* t)
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
||||
(is (eq :REQUEST (getf result :TYPE)))
|
||||
(setf *read-eval* nil))))
|
||||
|
||||
(test test-json-alist-to-plist-simple
|
||||
"Contract 5: converts simple alist to keyword plist."
|
||||
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :ACTION (first result)))
|
||||
(is (string= "shell" (second result)))
|
||||
(is (eq :CMD (third result)))
|
||||
(is (string= "echo hello" (fourth result))))))
|
||||
|
||||
(test test-json-alist-to-plist-nested
|
||||
"Contract 5: nested alists recurse into nested plists."
|
||||
(let ((alist (list (cons "tool" "write-file")
|
||||
(cons "args" (list (cons "filepath" "/tmp/x")
|
||||
(cons "content" "hi"))))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :TOOL (first result)))
|
||||
(is (eq :ARGS (third result)))
|
||||
(let ((inner (fourth result)))
|
||||
(is (eq :FILEPATH (first inner)))
|
||||
(is (string= "/tmp/x" (second inner)))
|
||||
(is (eq :CONTENT (third inner)))))))
|
||||
|
||||
(test test-json-alist-to-plist-array-passthrough
|
||||
"Contract 5: JSON arrays pass through unchanged."
|
||||
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :NAMES (first result)))
|
||||
(is (equal (list "alice" "bob") (second result))))))
|
||||
|
||||
(test test-json-alist-to-plist-null
|
||||
"Contract 5: nil passes through unchanged."
|
||||
(let ((result (json-alist-to-plist nil)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-json-alist-to-plist-scalar
|
||||
"Contract 5: scalar values pass through."
|
||||
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :COUNT (first result)))
|
||||
(is (= 42 (second result)))
|
||||
(is (eq :ACTIVE (third result)))
|
||||
(is (eq :true (fourth result))))))
|
||||
|
||||
(test test-assemble-config-section
|
||||
"Contract v0.7.2: config section contains Passepartout and version."
|
||||
(let ((section (passepartout::assemble-config-section)))
|
||||
(is (stringp section))
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
#+end_src
|
||||
527
org/core-skills.org
Normal file
527
org/core-skills.org
Normal file
@@ -0,0 +1,527 @@
|
||||
#+TITLE: The Skill Engine (skills.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :org:skills:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-skills.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Skill Engine is the dynamic loading and lifecycle manager for all Passepartout skills. It discovers skill files in the skills directory, resolves their dependency order, loads them into jailed packages, and exports their public symbols into the ~passepartout~ package.
|
||||
|
||||
** Late-Binding Intelligence
|
||||
|
||||
Hardcoding logic into a compiled binary creates a brittle kernel. Every time you add a capability, you must recompile, restart, and re-deploy. Skills solve this by being:
|
||||
|
||||
1. **Discovered at boot** — the engine scans a directory for skill files and loads whatever it finds. No registration step needed.
|
||||
2. **Dependency-ordered** — skills declare dependencies via ~#+DEPENDS_ON:~ headers. The topological sort ensures they load in the right order.
|
||||
3. **Hot-reloadable** — a skill can be replaced at runtime without restarting the daemon. The new version is compiled into a fresh jail package and swapped in.
|
||||
4. **Self-documenting** — each skill is a single Org file containing prose, code, metadata, and tests. The "Why" and the "How" are unified.
|
||||
|
||||
** The Jailed Package Model
|
||||
|
||||
Every skill loads into its own package (e.g., ~PASSEPARTOUT.SKILLS.SECURITY-DISPATCHER~). This prevents name conflicts between skills — two skills can define a function called ~process~ without collision, because each lives in its own namespace.
|
||||
|
||||
After loading, the engine exports the skill's public symbols into the ~passepartout~ package, making them available to other skills and the org. The export filter uses the skill's short name as a prefix — for example, the Security Dispatcher exports only symbols starting with ~DISPATCHER-~.
|
||||
|
||||
This is how the "thin org, fat skills" principle works in practice: the org provides the loading infrastructure; the skills provide all the intelligence.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (lisp-syntax-validate code-string): returns T if the Lisp code is
|
||||
structurally valid, nil if reader errors are detected.
|
||||
2. (skill-topological-sort dir): reads org files in a directory, parses
|
||||
~#+DEPENDS_ON:~ declarations, returns files sorted such that
|
||||
dependencies come before dependents.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
** Utility functions
|
||||
|
||||
Helper functions used by the skill loader and other components.
|
||||
|
||||
*** Cosine similarity
|
||||
|
||||
Computes the cosine similarity between two numeric vectors. Used by the peripheral vision system for semantic relevance scoring — if the agent's current focus has a vector embedding, objects with similar embeddings get promoted to foveal detail.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun vector-cosine-similarity (v1 v2)
|
||||
"Computes cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
||||
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
||||
#+end_src
|
||||
|
||||
** Skill data structures
|
||||
|
||||
The ~skill~ struct holds all metadata about a loaded skill: its name, priority, dependencies, trigger function, probabilistic prompt generator, and deterministic gate. The ~skill-entry~ struct tracks the loading state of each discovered skill file.
|
||||
|
||||
#+begin_src lisp
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"Tracks all discovered skill files and their loading state.")
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *standing-mandates* nil
|
||||
"List of functions (context) → string-or-nil. Each is called on every think() cycle.
|
||||
When non-nil, the returned string is injected into the IDENTITY section of the system prompt.
|
||||
Unlike skills (which activate on triggers), standing mandates are always consulted.")
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
#+end_src
|
||||
|
||||
** Skill discovery (skill-triggered-find)
|
||||
|
||||
Iterates the registry and returns the highest-priority skill whose trigger function matches the current context. Only skills with a probabilistic prompt are considered (purely deterministic skills don't need LLM attention).
|
||||
|
||||
This is how the system determines which skill "owns" the current user input. For example, if the REPL skill's trigger matches the input, the REPL skill provides the prompt template that shapes how the LLM responds.
|
||||
|
||||
#+begin_src lisp
|
||||
;; Alias: find-triggered-skill → skill-triggered-find
|
||||
(defun find-triggered-skill (context)
|
||||
(skill-triggered-find context))
|
||||
|
||||
(defun skill-triggered-find (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skill-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
#+end_src
|
||||
|
||||
** Standing Mandates
|
||||
|
||||
Standing mandates are cross-cutting instructions injected into every LLM system prompt. They live in ~*standing-mandates*~, a list of functions ~(context) → string-or-nil~. Each is called on every reasoning cycle; nil results are skipped.
|
||||
|
||||
This is the mechanism for always-on behavioral instructions. Skills call their registered trigger function to determine if they should activate for a given context; standing mandates always run and decide themselves whether to contribute text. Use ~push~ to register:
|
||||
|
||||
#+begin_example
|
||||
(push #'my-mandate *standing-mandates*)
|
||||
#+end_example
|
||||
|
||||
** Skill registration macro (defskill)
|
||||
|
||||
The primary API for skills. Each skill file calls this once to register itself. The macro creates a ~skill~ struct and stores it in ~*skill-registry*~ keyed by the skill's name.
|
||||
|
||||
#+begin_src lisp
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
||||
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skill-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
#+end_src
|
||||
|
||||
** Dependency resolution (skill-dependencies-resolve)
|
||||
|
||||
Recursively resolves all transitive dependencies for a given skill, returning an ordered list. Uses a standard graph traversal with a ~seen~ set to prevent infinite recursion from circular dependencies.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun skill-dependencies-resolve (skill-name)
|
||||
"Resolves transitive dependencies. Returns list of skill names in dependency order."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skill-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
#+end_src
|
||||
|
||||
** Skill File Analysis (skill-metadata-parse)
|
||||
|
||||
Extracts the ~:ID~ and ~#+DEPENDS_ON:~ declarations from a skill's Org file. Used by the topological sorter to order skills correctly.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun skill-metadata-parse (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
||||
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
||||
(unless (string= d "") (push d dependencies))))
|
||||
(setf pos end)))))
|
||||
(values id (reverse dependencies))))
|
||||
#+end_src
|
||||
|
||||
** Dependency Resolution (skill-topological-sort)
|
||||
|
||||
Returns a list of skill filepaths sorted by dependency order. Uses Kahn's algorithm: collect all files, build an adjacency graph from ~#+DEPENDS_ON:~ declarations, and topologically sort them. Skills with no dependencies are sorted alphabetically.
|
||||
|
||||
Both ~.org~ and ~.lisp~ files are included. For each skill, the ~.org~ file supplies the dependency metadata; if a ~.lisp~ file exists, it's loaded instead of tangling from the ~.org~ at load time.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun skill-topological-sort (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency."
|
||||
(let* ((org-files (uiop:directory-files skills-dir "*.org"))
|
||||
(lisp-files (uiop:directory-files skills-dir "*.lisp"))
|
||||
(all-files (append org-files lisp-files))
|
||||
(files (remove-if (lambda (f)
|
||||
(let ((n (pathname-name f)))
|
||||
(or (string= n "core-package")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-transport")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-perceive")
|
||||
(string= n "core-reason")
|
||||
(string= n "core-act")
|
||||
(string= n "core-pipeline")
|
||||
(string= n "core-manifest")
|
||||
(string= n "neuro-router")
|
||||
(string= n "neuro-explorer")
|
||||
(string= n "channel-tui"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(progn
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(unless (gethash (string-downcase filename) adj)
|
||||
(setf (gethash (string-downcase filename) adj) nil)))
|
||||
(multiple-value-bind (id deps) (skill-metadata-parse file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps)))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected")
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
#+end_src
|
||||
|
||||
** Jailed Loading (skill-load-from-org)
|
||||
|
||||
The primary skill loader. Given a path to an ~.org~ file:
|
||||
|
||||
1. Reads the Org file and collects all ~#+begin_src lisp~ blocks (excluding test blocks and blocks with ~:tangle no~)
|
||||
2. Validates the Lisp syntax before loading
|
||||
3. Creates a jailed package named after the skill (e.g., ~PASSEPARTOUT.SKILLS.SECURITY-DISPATCHER~) with ~:use :passepartout~
|
||||
4. Evaluates the collected Lisp forms in that package
|
||||
5. Scans the package for symbols matching the skill's name prefix and exports them to the ~passepartout~ package
|
||||
|
||||
The validation step is critical: invalid Lisp in an org block would crash the loader. The validator uses ~read~ with ~*read-eval*~ bound to nil to safely detect syntax errors without evaluating.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun lisp-syntax-validate (code-string)
|
||||
"Checks if a string contains valid Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun skill-package-forms-strip (code-string)
|
||||
"Removes (in-package :passepartout) forms only — preserves test-package
|
||||
declarations so embedded test code evaluates in the correct package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(if (uiop:string-prefix-p "(in-package :passepartout)" trimmed)
|
||||
(setf result (concatenate 'string result (string #\Newline)))
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun tangle-target-extract (line)
|
||||
"Extracts the value of the :tangle header."
|
||||
(let ((pos (search ":tangle" line)))
|
||||
(when pos
|
||||
(let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
||||
(let ((end (position #\Space rest)))
|
||||
(if end (subseq rest 0 end) rest))))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
||||
(setf in-lisp-block t)
|
||||
(let ((target (tangle-target-extract clean-line)))
|
||||
(setf collect-this-block (or (null target)
|
||||
(and (not (search "no" target))
|
||||
(not (search "/tests" target)))))))
|
||||
((uiop:string-prefix-p "#+end_src" clean-line)
|
||||
(setf in-lisp-block nil) (setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(if (= (length lisp-code) 0)
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
|
||||
(unless valid-p (error err)))
|
||||
;; Pre-eval sandbox scan: block before any code executes
|
||||
(multiple-value-bind (blocked-p blocked-syms)
|
||||
(skill-source-scan lisp-code)
|
||||
(when blocked-p
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name blocked-syms)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-org nil)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg)))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
#+end_src
|
||||
|
||||
** Sandbox Source Scan (skill-source-scan)
|
||||
|
||||
Scans Lisp source text for references to restricted symbols before any
|
||||
code is evaluated. This prevents malicious skills from executing even a
|
||||
single form. The restricted symbols cover process spawning
|
||||
(~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~), thread
|
||||
creation (~bt:make-thread~), and
|
||||
socket operations (~usocket:socket-connect~, ~hunchentoot:start~).
|
||||
|
||||
Returns two values: T/NIL (blocked-p) and a list of matched symbol names.
|
||||
The scan is a text-level regex check — it catches direct references but
|
||||
not obfuscated ones. The post-eval ~symbol-function~ comparison in
|
||||
~load-skill-from-lisp~ catches those.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *skill-restricted-symbols*
|
||||
'("uiop:run-program" "uiop:shell" "uiop:run-shell-command"
|
||||
"bt:make-thread" "bordeaux-threads:make-thread"
|
||||
"usocket:socket-connect" "usocket:socket-listen"
|
||||
"hunchentoot:start" "hunchentoot:accept-connections")
|
||||
"Symbol patterns blocked from skill source code at load time.")
|
||||
|
||||
(defun skill-source-scan (code-string)
|
||||
"Scans CODE-STRING for restricted symbol references.
|
||||
Returns (values blocked-p matched-symbols)."
|
||||
(let ((lower (string-downcase code-string))
|
||||
(matches nil))
|
||||
(dolist (pattern *skill-restricted-symbols*)
|
||||
(when (search pattern lower)
|
||||
(push pattern matches)))
|
||||
(values (and matches t) (nreverse matches))))
|
||||
#+end_src
|
||||
|
||||
** Loading from Pre-Tangled Lisp (skill-load-from-lisp)
|
||||
|
||||
Loads a pre-tangled ~.lisp~ file directly, without parsing the Org source. This is faster than ~load-skill-from-org~ because it skips the block extraction and syntax validation (the Lisp was already validated when tangled).
|
||||
|
||||
The same jailed package and symbol export process applies.
|
||||
|
||||
The sandbox check runs *before* evaluation: the source text is scanned for references to restricted symbols (~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~, ~bt:make-thread~, ~usocket:socket-connect~, ~hunchentoot:start~). If the source references any restricted symbol, the skill is blocked immediately without executing any code. A post-eval secondary check catches indirect references (via ~symbol-function~ comparison).
|
||||
|
||||
#+begin_src lisp
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
"Loads a .lisp skill file directly, filtering out in-package forms."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (skill-package-forms-strip (uiop:read-file-string filepath)))
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
|
||||
(unless valid-p (error err)))
|
||||
;; Pre-eval sandbox scan: block before any code executes
|
||||
(multiple-value-bind (blocked-p blocked-syms)
|
||||
(skill-source-scan content)
|
||||
(when blocked-p
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name blocked-syms)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-lisp nil)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(with-input-from-string (s content)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
(let* ((jailed-pkg (find-package pkg-name))
|
||||
(restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND"))
|
||||
(violation (loop for r in restricted
|
||||
for sym = (find-symbol r :uiop)
|
||||
when (and sym (fboundp sym)
|
||||
(loop for skill-sym being the symbols of jailed-pkg
|
||||
when (and (fboundp skill-sym)
|
||||
(eq (symbol-function skill-sym)
|
||||
(symbol-function sym)))
|
||||
return skill-sym))
|
||||
collect (format nil "~a" sym))))
|
||||
(when violation
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name violation)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-lisp nil))
|
||||
(log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(ignore-errors (export sym target-pkg))))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
#+end_src
|
||||
|
||||
** Initialize (skill-initialize-all)
|
||||
|
||||
Boot-time entry point. Scans the skills directory, topologically sorts the files, and loads each one. Called from ~main~ in the metabolic loop and from the REPL for hot-reload.
|
||||
|
||||
Skills are loaded from ~$PASSEPARTOUT_DATA_DIR/lisp/~ where both core and skill
|
||||
files live after tangling. The org source files live in ~org/~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun skill-initialize-all ()
|
||||
"Initializes all skills from the XDG data directory."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir))))
|
||||
(unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil))
|
||||
(let ((sorted-files (skill-topological-sort skills-dir)))
|
||||
(log-message "LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
(dolist (file sorted-files)
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
#+end_src
|
||||
319
org/core-transport.org
Normal file
319
org/core-transport.org
Normal file
@@ -0,0 +1,319 @@
|
||||
#+TITLE: Communication Protocol (communication.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:protocol:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/core-transport.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Communication Protocol defines how Passepartout speaks to the outside world. It sits between the metabolic loop and the network, providing framed, length-prefixed message transport over TCP.
|
||||
|
||||
Every message is an S-expression (plist) prefixed with a 6-character hex length:
|
||||
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.4.0"))
|
||||
|
||||
This is a deliberate rejection of JSON, Protocol Buffers, or any other serialization format. The message format is Lisp-native because:
|
||||
|
||||
1. The agent generates and consumes these messages inside the cognitive loop — no serialization layer needed
|
||||
2. The format is human-readable and trivially debuggable with a text editor
|
||||
3. The length prefix prevents framing attacks (no "read until newline" ambiguity)
|
||||
|
||||
** Why Length-Prefixed Framing?
|
||||
|
||||
A naive TCP protocol that reads until newline fails when:
|
||||
- A message contains a newline character (which Lisp plists can)
|
||||
- A message is split across TCP packets (read returns partial data)
|
||||
- A malicious client sends an infinite stream without newlines
|
||||
|
||||
The length prefix solves all three problems. The reader reads exactly 6 characters (the hex length), then reads exactly that many additional characters. No ambiguous termination, no partial message handling, no newline worries.
|
||||
|
||||
The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This is sufficient for any single message the agent would produce. Larger payloads should be split across multiple messages.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (frame-message msg): serializes a plist message to a length-prefixed
|
||||
string. The first 6 characters are the hex-encoded payload length.
|
||||
2. (read-framed-message stream): reads a framed message from a stream,
|
||||
returning the deserialized plist. Consumes exactly the length-prefixed
|
||||
bytes.
|
||||
3. Round-trip invariant: ~(read-framed-message (make-string-input-stream
|
||||
(frame-message msg)))~ equals ~msg~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Protocol Accessor (proto-get)
|
||||
|
||||
Case-insensitive property list accessor used throughout the pipeline.
|
||||
Returns the value associated with KEY in PLIST by interning a keyword.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun proto-get (plist key)
|
||||
"Look up KEY in PLIST with case-insensitive keyword normalization."
|
||||
(let ((key-upcase (string-upcase (string key))))
|
||||
(loop for (k v) on plist by #'cddr
|
||||
when (and (keywordp k)
|
||||
(string-equal (string k) key-upcase))
|
||||
do (return v))))
|
||||
#+end_src
|
||||
|
||||
** Actuator Registry
|
||||
|
||||
The global registry mapping target keywords (~:cli~, ~:telegram~, ~:signal~, etc.) to their physical actuator functions. Extensible at runtime — skills can register new actuators via ~register-actuator~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
#+end_src
|
||||
|
||||
** Message Framing
|
||||
|
||||
Three functions handle the full message lifecycle: sanitize (strip non-serializable state), frame (serialize + prefix), and read (parse from stream).
|
||||
|
||||
*** Sanitize Protocol Message
|
||||
|
||||
Strips transient runtime state (~:reply-stream~, ~:socket~, ~:stream~) from a message plist before sending it over the network. These are Lisp stream objects that cannot be serialized and have no meaning to the remote end.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun protocol-message-sanitize (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (protocol-message-sanitize v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
#+end_src
|
||||
|
||||
*** Frame Message
|
||||
|
||||
Serializes a plist to a length-prefixed string: 6-character hex length followed by the ~prin1~ representation.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (protocol-message-sanitize msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
#+end_src
|
||||
|
||||
*** Read Framed Message
|
||||
|
||||
Reads a complete framed message from a TCP stream. Handles leading whitespace between messages, partial reads, and malformed length headers gracefully. Returns the parsed S-expression, or ~:eof~ if the stream is closed, or ~:error~ if the message is malformed.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
for ws-count from 0
|
||||
while (and (not (eq char :eof)) (< ws-count 4096)
|
||||
(member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(if (< count 6)
|
||||
:eof
|
||||
(let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
:error
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil))
|
||||
(handler-case (read-from-string msg-buffer)
|
||||
(error () :error)))))))))
|
||||
(error () :error))))
|
||||
#+end_src
|
||||
|
||||
** Server Listener (daemon-start)
|
||||
|
||||
The TCP server that accepts connections from CLI and TUI clients. Each connection gets a dedicated thread (~client-handle-connection~).
|
||||
|
||||
The daemon sends a handshake message on connection, then enters a read loop, injecting each received message into the metabolic loop via ~stimulus-inject~. The ~:health-check~ message type is handled inline (not sent to the cognitive loop) so that health checks work even when the agent is busy.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-socket* nil)
|
||||
(defvar *daemon-port* nil "The port the daemon is actually listening on (may differ from default if 9105 was in use).")
|
||||
|
||||
(defun client-handle-connection (socket)
|
||||
"Handles a single TUI/CLI client connection in a dedicated thread."
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.7.2")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
(cond
|
||||
((eq msg :eof) (return))
|
||||
((eq msg :error) (return))
|
||||
((eq (getf msg :type) :health-check)
|
||||
(let ((health-msg (list :type :health-response
|
||||
:status (or (and (boundp 'passepartout::*system-health*)
|
||||
(symbol-value 'passepartout::*system-health*))
|
||||
:unknown)
|
||||
:checked-p (or (and (boundp 'passepartout::*health-check-ran*)
|
||||
(symbol-value 'passepartout::*health-check-ran*))
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (stimulus-inject msg :stream stream))))))
|
||||
(error (c) (log-message "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
(defun start-daemon (&key (port 9105) (max-retries 10))
|
||||
"Starts the network listener for TUI/CLI clients.
|
||||
If PORT is taken, tries subsequent ports up to PORT+MAX-RETRIES."
|
||||
(loop for attempt from 0 below max-retries
|
||||
for p = (+ port attempt)
|
||||
do (handler-case
|
||||
(progn
|
||||
(setf *daemon-socket* (usocket:socket-listen "127.0.0.1" p :reuse-address t))
|
||||
(log-message "DAEMON: Listening on localhost:~a" p)
|
||||
(setf *daemon-port* p)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(let ((client-socket (usocket:socket-accept *daemon-socket*)))
|
||||
(when client-socket
|
||||
(bt:make-thread (lambda () (client-handle-connection client-socket))
|
||||
:name "passepartout-client-handler")))))
|
||||
:name "passepartout-server-listener")
|
||||
(return p))
|
||||
(usocket:address-in-use-error ()
|
||||
(when (= attempt (1- max-retries))
|
||||
(log-message "DAEMON: All ports ~d-~d in use — giving up" port (+ port max-retries -1))
|
||||
(error "No available port for daemon"))
|
||||
(log-message "DAEMON: Port ~d in use, trying ~d..." p (1+ p))))))
|
||||
#+end_src
|
||||
|
||||
** Handshake Logic
|
||||
|
||||
The first message sent to every new connection. The client can use this to verify the protocol version and the daemon's capabilities.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :ORG-AST))))
|
||||
#+end_src
|
||||
|
||||
** Structural Validation
|
||||
|
||||
Validates that an incoming message has the minimum required structure: a plist with a valid ~:type~ field. Used by the protocol validator skill to reject malformed messages before they enter the cognitive loop.
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun protocol-schema-validate (msg)
|
||||
"Strict structural validation for incoming protocol messages."
|
||||
(unless (listp msg) (error "Message must be a plist"))
|
||||
(let ((type (proto-get msg :type)))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Backward-compatibility alias for protocol-schema-validate."
|
||||
(protocol-schema-validate msg))
|
||||
#+end_src
|
||||
|
||||
** Protocol Smoke Test (manual for REPL evaluation)
|
||||
|
||||
Use this function to manually verify that the daemon is alive and the framing protocol works end-to-end. It connects to a running daemon, reads the HELLO handshake, sends a "hi" message, and reads the response.
|
||||
|
||||
#+begin_src lisp :tangle no
|
||||
(defun test-daemon-protocol ()
|
||||
(handler-case
|
||||
(let* ((socket (usocket:socket-connect "127.0.0.1" 9105))
|
||||
(stream (usocket:socket-stream socket)))
|
||||
(format t "Connected.~%")
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(when (= count 6)
|
||||
(let* ((len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(format t "HELLO: ~a~%" msg-buf))))
|
||||
(let* ((msg '(:TYPE :EVENT :META (:SOURCE :tui) :PAYLOAD (:SENSOR :user-input :TEXT "hi")))
|
||||
(framed (frame-message msg)))
|
||||
(format stream "~a" framed)
|
||||
(finish-output stream)
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(when (= count 6)
|
||||
(let* ((len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(format t "Response: ~a~%" msg-buf)))))
|
||||
(usocket:socket-close socket))
|
||||
(error (c) (format t "Error: ~a~%" c))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the framing protocol correctly serializes and deserializes messages.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
#+end_src
|
||||
285
org/cost-tracker.org
Normal file
285
org/cost-tracker.org
Normal file
@@ -0,0 +1,285 @@
|
||||
#+TITLE: Cost Tracker — per-session token cost accounting
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :token-economics:cost-tracking:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/cost-tracker.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
Cost tracking gives the user visibility into what the agent spends on their
|
||||
behalf. No competitor provides this — Claude Code and Copilot obscure cost
|
||||
behind flat-rate subscriptions. Passepartout tracks every LLM call, logs
|
||||
cumulative cost, and exposes it via a ~/cost~ TUI command.
|
||||
|
||||
The tracking is minimal and accurate to within ~10-15% (using the token
|
||||
heuristic from tokenizer.lisp). It persists across daemon restarts via
|
||||
~*session-cost*~ in the memory store.
|
||||
|
||||
** v0.8.0 — Session Summary for Sidebar
|
||||
|
||||
The sidebar's Cost panel needs an at-a-glance cost summary: total spent,
|
||||
call count, per-provider breakdown. ~cost-session-summary~ packages the
|
||||
three existing accessors (~cost-session-total~, ~cost-session-calls~,
|
||||
~cost-by-provider~) into a single plist ~(:total <float> :calls <int>
|
||||
:by-provider <alist>)~. This is a thin wrapper (~5 lines) — the data
|
||||
already exists; the function exposes it in the shape the TUI expects.
|
||||
|
||||
Called from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
|
||||
Degrades gracefully to nil when cost-tracker is not loaded.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (cost-track-call provider prompt-text response-text): compute and
|
||||
accumulate the cost of a single LLM call. Returns the cost in USD.
|
||||
2. (cost-session-total): returns the current session's total cost.
|
||||
3. (cost-session-reset): zeroes the session cost accumulator.
|
||||
4. (cost-format-budget-status total budget): returns a human-readable
|
||||
budget status string for the TUI status bar.
|
||||
5. (cost-session-summary): returns plist
|
||||
~(:total <float> :calls <int> :by-provider <alist>)~ aggregating
|
||||
all three session cost accessors. Consumed by the TUI actuator
|
||||
for the sidebar Cost panel (v0.8.0).
|
||||
6. (budget-remaining-usd): returns the remaining budget in USD, or
|
||||
~most-positive-double-float~ when no budget is set.
|
||||
7. (budget-exhausted-p): returns T when a budget is set and fully
|
||||
consumed. ~fboundp~-guarded at call sites so the checker is
|
||||
a no-op when cost-tracker is not loaded.
|
||||
8. (budget-estimate-call prompt-text): estimates the dollar cost of a
|
||||
pending LLM call from the prompt text. Returns 0.0 when the
|
||||
tokenizer skill is not loaded (allows the call through).
|
||||
9. (budget-exhaustion-message): returns a ~:REQUEST~ plist with a
|
||||
human-readable message explaining the budget cap. Injected as the
|
||||
LLM response when the budget is exhausted.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Session cost state
|
||||
#+begin_src lisp
|
||||
(defvar *session-cost* (list :total 0.0 :calls 0 :by-provider nil)
|
||||
"Session cost accumulator: (:total <float> :calls <int> :by-provider <alist>)")
|
||||
|
||||
(defvar *session-cost-lock* (bordeaux-threads:make-lock "session-cost-lock")
|
||||
"Lock protecting *session-cost* from concurrent updates.")
|
||||
#+end_src
|
||||
|
||||
** Per-call cost tracking
|
||||
#+begin_src lisp
|
||||
(defun cost-track-call (provider prompt-text &optional response-text)
|
||||
"Compute and accumulate the cost of a single LLM call.
|
||||
Returns the cost of this call in USD."
|
||||
(let* ((input-tokens (if (fboundp 'count-tokens)
|
||||
(funcall (symbol-function 'count-tokens) (or prompt-text ""))
|
||||
(ceiling (length (or prompt-text "")) 4)))
|
||||
(output-tokens (if (and response-text (fboundp 'count-tokens))
|
||||
(funcall (symbol-function 'count-tokens) response-text)
|
||||
0))
|
||||
(total-tokens (+ input-tokens output-tokens))
|
||||
(cost (provider-token-cost provider total-tokens)))
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(incf (getf *session-cost* :total) cost)
|
||||
(incf (getf *session-cost* :calls))
|
||||
(let ((by-prov (getf *session-cost* :by-provider)))
|
||||
(let ((entry (assoc provider by-prov)))
|
||||
(if entry
|
||||
(incf (cdr entry) cost)
|
||||
(setf (getf *session-cost* :by-provider)
|
||||
(acons provider cost by-prov))))))
|
||||
(log-message "COST TRACKER: ~a call: ~,4f USD (session total: ~,4f USD)"
|
||||
provider cost (getf *session-cost* :total))
|
||||
cost))
|
||||
#+end_src
|
||||
|
||||
** Session total
|
||||
#+begin_src lisp
|
||||
(defun cost-session-total ()
|
||||
"Returns the current session's total cost in USD."
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(getf *session-cost* :total)))
|
||||
|
||||
(defun cost-session-calls ()
|
||||
"Returns the total number of LLM calls in this session."
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(getf *session-cost* :calls)))
|
||||
|
||||
(defun cost-by-provider ()
|
||||
"Returns an alist of (provider . total-cost) for this session."
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(getf *session-cost* :by-provider)))
|
||||
#+end_src
|
||||
|
||||
** Session summary (v0.8.0)
|
||||
#+begin_src lisp
|
||||
(defun cost-session-summary ()
|
||||
"Returns plist (:total <float> :calls <int> :by-provider <alist>)."
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(list :total (getf *session-cost* :total)
|
||||
:calls (getf *session-cost* :calls)
|
||||
:by-provider (getf *session-cost* :by-provider))))
|
||||
#+end_src
|
||||
|
||||
** Session reset
|
||||
#+begin_src lisp
|
||||
(defun cost-session-reset ()
|
||||
"Zeroes the session cost accumulator."
|
||||
(bordeaux-threads:with-lock-held (*session-cost-lock*)
|
||||
(setf (getf *session-cost* :total) 0.0)
|
||||
(setf (getf *session-cost* :calls) 0)
|
||||
(setf (getf *session-cost* :by-provider) nil)))
|
||||
#+end_src
|
||||
|
||||
** Budget status formatting
|
||||
#+begin_src lisp
|
||||
(defun cost-format-budget-status (&optional (daily-budget nil))
|
||||
"Returns a string for the TUI status bar showing session cost.
|
||||
If DAILY-BUDGET is provided, includes percentage of budget used."
|
||||
(let* ((total (cost-session-total))
|
||||
(calls (cost-session-calls))
|
||||
(budget (or daily-budget
|
||||
(ignore-errors
|
||||
(parse-integer (uiop:getenv "COST_BUDGET_DAILY")))
|
||||
0))
|
||||
(pct (if (> budget 0) (* 100.0 (/ total budget)) 0.0))
|
||||
(status (cond
|
||||
((= calls 0) "—")
|
||||
((< pct 50) "OK")
|
||||
((< pct 90) "WARN")
|
||||
(t "HIGH"))))
|
||||
(if (> budget 0)
|
||||
(format nil "[Cost: $~,2f (~,0f%) ~a]" total pct status)
|
||||
(format nil "[Cost: $~,2f | ~d calls]" total calls))))
|
||||
#+end_src
|
||||
|
||||
** Hook into cascade
|
||||
|
||||
This function is called from ~backend-cascade-call~ after each successful
|
||||
LLM invocation to record the cost.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun cost-track-backend-call (backend prompt-text &optional response-text)
|
||||
"Track cost of a backend cascade call."
|
||||
(cost-track-call backend prompt-text response-text))
|
||||
#+end_src
|
||||
|
||||
** Budget enforcement (v0.5.0 deferred)
|
||||
|
||||
Session-wide cost caps that refuse LLM calls when the budget is exhausted.
|
||||
The budget is set via ~SESSION_BUDGET_USD~ env var (default: no limit).
|
||||
When exceeded, the agent falls back to deterministic-only mode — pure Lisp
|
||||
operations still work, but no cascade calls are made until the cap is raised
|
||||
or the session is reset.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *session-budget*
|
||||
(ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD")))
|
||||
"Maximum USD to spend in this session. NIL means no limit.")
|
||||
|
||||
(defun budget-remaining-usd ()
|
||||
"Returns remaining budget in USD, or a large sentinel if unlimited."
|
||||
(if *session-budget*
|
||||
(let ((remaining (- *session-budget* (cost-session-total))))
|
||||
(if (< remaining 0) 0.0 remaining))
|
||||
most-positive-double-float))
|
||||
|
||||
(defun budget-exhausted-p ()
|
||||
"T if the session budget is set and fully consumed."
|
||||
(and *session-budget* (<= (budget-remaining-usd) 0.0)))
|
||||
|
||||
(defun budget-estimate-call (prompt-text)
|
||||
"Estimate the dollar cost of a pending LLM call from its prompt text.
|
||||
Returns 0.0 if the tokenizer is not loaded (allows call through)."
|
||||
(if (fboundp 'count-tokens)
|
||||
(let* ((tokens (funcall (symbol-function 'count-tokens) (or prompt-text "")))
|
||||
(cost (provider-token-cost (first *provider-cascade*) tokens)))
|
||||
cost)
|
||||
0.0))
|
||||
|
||||
(defun budget-exhaustion-message ()
|
||||
"Returns a user-facing plist explaining that the budget is spent."
|
||||
(let ((total (cost-session-total))
|
||||
(cap *session-budget*))
|
||||
(list :TYPE :REQUEST
|
||||
:PAYLOAD (list :ACTION :MESSAGE
|
||||
:TEXT (format nil "Session budget exhausted: $~,4f of $~,2f spent. Raise SESSION_BUDGET_USD or reset with /cost-reset to continue."
|
||||
total cap)
|
||||
:EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised."))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-cost-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:cost-suite))
|
||||
|
||||
(in-package :passepartout-cost-tests)
|
||||
|
||||
(def-suite cost-suite :description "Cost tracking and budget management")
|
||||
(in-suite cost-suite)
|
||||
|
||||
(test test-cost-track-call
|
||||
"Contract 1: cost-track-call returns a positive number."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "hello world")))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-total-accumulates
|
||||
"Contract 2: session total grows with multiple calls."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :deepseek "world")
|
||||
(let ((total (cost-session-total)))
|
||||
(is (> total 0.0))
|
||||
(is (= 2 (cost-session-calls)))))
|
||||
|
||||
(test test-cost-session-reset
|
||||
"Contract 3: cost-session-reset zeroes the accumulator."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(is (> (cost-session-total) 0.0))
|
||||
(cost-session-reset)
|
||||
(is (= 0.0 (cost-session-total)))
|
||||
(is (= 0 (cost-session-calls))))
|
||||
|
||||
(test test-cost-format-budget-status
|
||||
"Contract 4: format-budget-status returns a string."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello world")
|
||||
(let ((status (cost-format-budget-status 100)))
|
||||
(is (stringp status))
|
||||
(is (search "$" status))))
|
||||
|
||||
(test test-cost-by-provider
|
||||
"Contract: cost-by-provider returns per-provider breakdown."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "a")
|
||||
(cost-track-call :groq "b")
|
||||
(let ((by (cost-by-provider)))
|
||||
(is (listp by))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by))))
|
||||
|
||||
(test test-cost-track-no-response
|
||||
"Contract 1: cost-track-call works without response-text."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "test")))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-summary
|
||||
"Contract 5: cost-session-summary returns plist with total, calls, by-provider."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :groq "world")
|
||||
(let ((s (cost-session-summary)))
|
||||
(is (> (getf s :total) 0.0))
|
||||
(is (= 2 (getf s :calls)))
|
||||
(let ((by (getf s :by-provider)))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by)))))
|
||||
#+end_src
|
||||
305
org/embedding-backends.org
Normal file
305
org/embedding-backends.org
Normal file
@@ -0,0 +1,305 @@
|
||||
#+TITLE: SKILL: Embedding Gateway (org-skill-embedding-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:system:embedding:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/embedding-backends.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-embedding~ converts text into vector representations for semantic search and memory retrieval. It provides three backends:
|
||||
|
||||
- ~:trigram~ — a zero-dependency fallback that uses character-trigram Jaccard similarity. Pure Lisp, works fully offline, captures lexical overlap.
|
||||
- ~:sha256~ — integrity-only (explicit opt-in). SHA-256 hashing for environments where even trivial computation is undesirable.
|
||||
- ~:local~ — any OpenAI-compatible ~/api/embeddings~ endpoint (Ollama, vLLM, etc.)
|
||||
- ~:openai~ — the OpenAI ~/v1/embeddings~ API with an API key
|
||||
- ~:native~ — in-process inference via llama.cpp / CFFI. 768-dim nomic-embed-text-v1.5, zero network calls, <100ms per document on CPU. Requires model file at ~/.local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf and libllama_wrap.so at /usr/local/lib.
|
||||
|
||||
The embedding queue (~embed-queue-object~ / ~embed-all-pending~) decouples document indexing from the main loop. On each heartbeat tick, ~embed-all-pending~ drains the queue and embeds all accumulated objects. This prevents indexing traffic from blocking conversational responses.
|
||||
|
||||
The default provider is ~:trigram~ — it captures lexical overlap (character trigram bloom filter → cosine similarity approximates Jaccard) and works immediately with zero configuration. Switch to ~:local~ or ~:openai~ when you have an embedding server; switch to ~:sha256~ for integrity-only deployments.
|
||||
|
||||
**Why not SHA-256 by default?** SHA-256 is a cryptographic hash with the avalanche property — one-bit input differences produce entirely different outputs. "implement user login form" and "implement user login forn" (one character difference) have completely different SHA-256 values → cosine similarity near zero. This makes SHA-256 correct for integrity verification (Merkle tree) but useless for similarity-based retrieval. The trigram Jaccard approach captures lexical overlap: "authentication" and "authenticate" share trigrams "aut", "uth", "the", "hen", "ent", "nti", "tic", "ica", producing high cosine similarity (0.80). "authentication" and "banana" share zero trigrams → 0.0 similarity.
|
||||
|
||||
This replaces the old ~system-embedding-gateway~ with the same logic but renamed to ~system-model-embedding~ to live alongside the other ~system-model-*~ skills.
|
||||
|
||||
* Implementation
|
||||
|
||||
** State
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *embedding-provider* :trigram
|
||||
"Active embedding provider: :trigram, :sha256, :local, :openai, :native.")
|
||||
|
||||
(defvar *embedding-queue* nil
|
||||
"Queue of text objects awaiting embedding.")
|
||||
|
||||
(defvar *embedding-batch-size* 10
|
||||
"Maximum texts per embedding API call.")
|
||||
#+end_src
|
||||
|
||||
** Local backend (OpenAI-compatible)
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-local (text)
|
||||
"Generate embeddings via a local OpenAI-compatible endpoint."
|
||||
(let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/api/embeddings" url)
|
||||
:headers '(("Content-Type" . "application/json"))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "Embedding failed: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** OpenAI backend
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-openai (text)
|
||||
"Generate embeddings via OpenAI compatible /v1/embeddings endpoint."
|
||||
(let* ((api-key (uiop:getenv "OPENAI_API_KEY"))
|
||||
(base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1"))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/embeddings" base-url)
|
||||
:headers `(("Content-Type" . "application/json")
|
||||
("Authorization" . ,(format nil "Bearer ~a" api-key)))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "OpenAI Embedding failed: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Trigram backend (v0.4.0)
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-sha256 (text)
|
||||
"SHA-256 based vector — integrity only, no semantic retrieval capability.
|
||||
For environments where even trivial computation is undesirable."
|
||||
(let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text)))
|
||||
(vec (make-array 8 :element-type 'single-float :initial-element 0.0)))
|
||||
(dotimes (i (min (length digest) 8))
|
||||
(setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0)))
|
||||
vec))
|
||||
|
||||
(defun embedding-backend-hashing (text)
|
||||
"Backward-compatibility alias for SHA-256 hashing."
|
||||
(embedding-backend-sha256 text))
|
||||
|
||||
(defun embedding-backend-trigram (text)
|
||||
"Trigram bloom filter — captures lexical overlap for semantic retrieval.
|
||||
Returns a 128-dim float vector where each position corresponds to a trigram hash.
|
||||
Pure Lisp, zero external dependencies, works fully offline."
|
||||
(let* ((s (string-trim '(#\Space #\Newline #\Tab) (string-downcase text)))
|
||||
(trigrams (make-hash-table :test 'equal))
|
||||
(result (make-array 128 :element-type 'single-float :initial-element 0.0)))
|
||||
(when (>= (length s) 3)
|
||||
(loop for i from 0 to (- (length s) 3)
|
||||
for tri = (subseq s i (+ i 3))
|
||||
do (setf (gethash tri trigrams) t)))
|
||||
(maphash (lambda (tri _) (declare (ignore _))
|
||||
(setf (aref result (mod (sxhash tri) 128)) 1.0))
|
||||
trigrams)
|
||||
result))
|
||||
#+end_src
|
||||
|
||||
** Object embedding and queuing
|
||||
#+begin_src lisp
|
||||
(defvar *embedding-backend* nil
|
||||
"Explicit backend override (nil = use *embedding-provider*).")
|
||||
|
||||
(defun embeddings-compute (text)
|
||||
"Compute an embedding vector for text using the active backend."
|
||||
(embed-object text))
|
||||
|
||||
(defun embed-object (text)
|
||||
"Embed a single text string using the active backend."
|
||||
(let* ((selected (or *embedding-backend* *embedding-provider* :trigram))
|
||||
(backend (case selected
|
||||
(:local #'embedding-backend-local)
|
||||
(:openai #'embedding-backend-openai)
|
||||
(:native
|
||||
(unless (fboundp 'embedding-backend-native)
|
||||
(embedding-native-ensure-loaded))
|
||||
#'embedding-backend-native)
|
||||
(:sha256 #'embedding-backend-sha256)
|
||||
(t #'embedding-backend-trigram))))
|
||||
(if backend
|
||||
(progn
|
||||
(log-message "EMBEDDING: Provider ~a, backend=~a" selected backend)
|
||||
(funcall backend text))
|
||||
(progn
|
||||
(log-message "EMBEDDING: No backend for provider ~a, using hashing" selected)
|
||||
(embedding-backend-hashing text)))))
|
||||
|
||||
(defun embed-queue-object (object)
|
||||
"Queue a text object for async embedding."
|
||||
(push object *embedding-queue*)
|
||||
(log-message "EMBEDDING: Queued object"))
|
||||
|
||||
(defun embed-all-pending ()
|
||||
"Drain the embedding queue, store vectors in the store-keyed objects."
|
||||
(let ((batch (nreverse *embedding-queue*)))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (item batch)
|
||||
(handler-case
|
||||
(let ((id (getf item :id))
|
||||
(text (getf item :text)))
|
||||
(when (and id text)
|
||||
(let ((vec (embeddings-compute text))
|
||||
(obj (gethash id *memory-store*)))
|
||||
(when (and obj vec (not (listp vec)))
|
||||
(setf (memory-object-vector obj) vec))
|
||||
(log-message "EMBEDDING: Computed vector for ~a (~d dims)" id (length vec)))))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
|
||||
|
||||
;; Apply env var override at load time
|
||||
(let ((provider-env (uiop:getenv "EMBEDDING_PROVIDER")))
|
||||
(when provider-env
|
||||
(let ((kw (intern (string-upcase provider-env) :keyword)))
|
||||
(setf *embedding-provider* kw)
|
||||
(log-message "EMBEDDING: Set provider to ~a from EMBEDDING_PROVIDER env" kw))))
|
||||
|
||||
(defun embedding-native-ensure-loaded ()
|
||||
"Lazy-load the native CFFI backend. First call blocks ~30s for model init."
|
||||
(when (fboundp 'embedding-backend-native)
|
||||
(return-from embedding-native-ensure-loaded t))
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname
|
||||
(or (uiop:getenv "PASSEPARTOUT_DATA_DIR")
|
||||
(namestring (merge-pathnames ".local/share/passepartout/"
|
||||
(user-homedir-pathname))))))
|
||||
(native-file (merge-pathnames "lisp/embedding-native.lisp" data-dir)))
|
||||
(handler-case
|
||||
(progn
|
||||
(load native-file :verbose nil :print nil)
|
||||
(log-message "EMBEDDING: Native backend loaded from ~a" native-file))
|
||||
(error (c)
|
||||
(error "Failed to load native embedding backend (~a): ~a" native-file c)))))
|
||||
|
||||
;; Preload native model if configured at startup
|
||||
(when (eq *embedding-provider* :native)
|
||||
(log-message "EMBEDDING: Native provider configured, preloading model...")
|
||||
(embedding-native-ensure-loaded)
|
||||
(handler-case
|
||||
(progn
|
||||
(embedding-native-load-model)
|
||||
(log-message "EMBEDDING: Native model preloaded (~d dims)"
|
||||
(embedding-native-get-dim)))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Preload deferred: ~a (will retry on first call)" c))))
|
||||
|
||||
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)
|
||||
#+end_src
|
||||
|
||||
** Stale vector marking
|
||||
#+begin_src lisp
|
||||
(defun mark-vector-stale (id &optional content)
|
||||
"Mark a memory object's vector as :pending and queue it for re-embedding.
|
||||
When content is not supplied, reads from the object in *memory-store*."
|
||||
(let* ((obj (gethash id *memory-store*))
|
||||
(text (or content (and obj (memory-object-content obj)))))
|
||||
(when obj
|
||||
(setf (memory-object-vector obj) :pending))
|
||||
(when text
|
||||
(push (list :id id :text text) *embedding-queue*)
|
||||
(log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id))
|
||||
(or obj text)))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration and Cron
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-embedding-backends
|
||||
:priority 70
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
;; Register periodic batch embedding via cron (when orchestrator available)
|
||||
(when (fboundp 'orchestrator-register-cron)
|
||||
(handler-case
|
||||
(orchestrator-register-cron :embed-batch
|
||||
"<2026-05-05 Tue +10m>"
|
||||
'embed-all-pending
|
||||
:reflex)
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Cron registration failed: ~a" c))))
|
||||
#+end_src
|
||||
|
||||
* Contract
|
||||
|
||||
1. (embeddings-compute text): produces a vector (single-float array) for
|
||||
any text string using the active backend (~*embedding-backend*~ or
|
||||
~*embedding-provider*~).
|
||||
2. (embedding-backend-hashing text): zero-dependency fallback. Returns
|
||||
an 8-element single-float vector deterministically from SHA-256.
|
||||
3. (embed-all-pending): drains ~*embedding-queue*~, computes vectors for
|
||||
all queued objects, and stores them in ~*memory-store*~ entries.
|
||||
4. (mark-vector-stale id &optional content): sets ~:vector~ to ~:pending~
|
||||
and pushes object to ~*embedding-queue*~ for background re-embedding.
|
||||
5. Cron: ~embed-all-pending~ is registered with the orchestrator to run
|
||||
on ~:reflex~ tier every 10 minutes for background batch processing.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-embedding-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:embedding-suite))
|
||||
|
||||
(in-package :passepartout-embedding-tests)
|
||||
|
||||
(fiveam:def-suite embedding-suite :description "Embedding gateway verification")
|
||||
(fiveam:in-suite embedding-suite)
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing
|
||||
"Contract 2: hashing backend produces 8-element float vector."
|
||||
(let ((vec (embedding-backend-hashing "hello world")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (= 8 (length vec)))
|
||||
(fiveam:is (every #'numberp (coerce vec 'list)))))
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing-deterministic
|
||||
"Contract 2: same input produces same vector."
|
||||
(let ((v1 (embedding-backend-hashing "test"))
|
||||
(v2 (embedding-backend-hashing "test")))
|
||||
(fiveam:is (equalp v1 v2))))
|
||||
|
||||
(fiveam:test test-embeddings-compute
|
||||
"Contract 1: embeddings-compute returns a float vector."
|
||||
(let ((vec (embeddings-compute "some text")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (> (length vec) 0))))
|
||||
|
||||
(fiveam:test test-embed-queue-and-drain
|
||||
"Contract 3: embed-all-pending drains queue and stores vectors."
|
||||
(let ((*embedding-queue* nil))
|
||||
(embed-queue-object '(:id "test-obj" :text "sample text"))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(embed-all-pending)
|
||||
(fiveam:is (null *embedding-queue*))))
|
||||
|
||||
(fiveam:test test-mark-vector-stale
|
||||
"Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed."
|
||||
(let ((*embedding-queue* nil))
|
||||
;; Create an object in memory with a vector
|
||||
(let ((obj (make-memory-object :id "stale-test" :content "stale content"
|
||||
:vector #(1.0 2.0 3.0))))
|
||||
(setf (gethash "stale-test" *memory-store*) obj)
|
||||
(mark-vector-stale "stale-test")
|
||||
(fiveam:is (eq :pending (memory-object-vector obj)))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(let ((item (first *embedding-queue*)))
|
||||
(fiveam:is (string= "stale-test" (getf item :id)))
|
||||
(fiveam:is (string= "stale content" (getf item :text))))
|
||||
;; Clean up
|
||||
(remhash "stale-test" *memory-store*))))
|
||||
#+end_src
|
||||
376
org/embedding-native.org
Normal file
376
org/embedding-native.org
Normal file
@@ -0,0 +1,376 @@
|
||||
#+TITLE: SKILL: Native Embedding Inference (org-skill-embedding-native.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:system:embedding:cffi:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/embedding-native.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
=system-model-embedding-native= provides in-process embedding inference via CFFI binding to llama.cpp. Unlike =:local= (Ollama REST API) and =:openai= (paid API), =:native= runs the embedding model directly in the SBCL process — zero network calls, zero external servers.
|
||||
|
||||
The bundled model is =nomic-embed-text-v1.5= (nomic-bert, 768-dim, 12 layers, Q4_K_M quantization, ~80MB) at =~/.local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf=. It is a BERT-family encoder-only model — single forward pass, no autoregressive decoding.
|
||||
|
||||
**Key architectural decisions**:
|
||||
- C wrapper library (=/usr/local/lib/libllama_wrap.so=) bridges CFFI pointer params to llama.cpp's struct-by-value API (CFFI cannot pass/return structs by value)
|
||||
- Struct sizes verified via C ~sizeof~ / ~offsetof~: =llama_model_params= (72B), =llama_context_params= (136B), =llama_batch= (56B)
|
||||
- Model and context cached globally in =*native-model*= / =*native-context*= to avoid reloading
|
||||
- BERT pooling: =llama_get_embeddings_seq= for sequence-level embedding (not =llama_get_embeddings_ith=)
|
||||
- =sb-int:set-floating-point-modes= :traps nil required before any llama.cpp call (FPU state conflict)
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package guard
|
||||
#+begin_src lisp
|
||||
(unless (find-package :passepartout)
|
||||
(make-package :passepartout :use '(:cl)))
|
||||
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** CFFI: Load C wrapper + llama libraries
|
||||
|
||||
The C wrapper (=libllama_wrap.so=) bridges struct-by-value: all wrapper functions take pure pointers and dereference internally.
|
||||
|
||||
#+begin_src lisp
|
||||
(cffi:define-foreign-library libllama_wrap (:unix "/usr/local/lib/libllama_wrap.so"))
|
||||
(cffi:use-foreign-library libllama_wrap)
|
||||
(cffi:define-foreign-library libllama (:unix "/usr/local/lib/libllama.so"))
|
||||
(cffi:use-foreign-library libllama)
|
||||
#+end_src
|
||||
|
||||
** CFFI: Struct definitions
|
||||
|
||||
Sizes verified via C =sizeof= / =offsetof= at build time.
|
||||
|
||||
#+begin_src lisp
|
||||
(cffi:defcstruct (llama-mparams :size 72)
|
||||
(devices :pointer) (tensor-buft :pointer) (n-gpu-layers :int32)
|
||||
(split-mode :int32) (main-gpu :int32) (_pad1 :int32)
|
||||
(tensor-split :pointer) (progress-cb :pointer) (progress-data :pointer)
|
||||
(kv-overrides :pointer) (vocab-only :bool) (use-mmap :bool)
|
||||
(_pad2 :uint8 :count 6))
|
||||
|
||||
(cffi:defcstruct (llama-cparams :size 136)
|
||||
(n-ctx :uint32)
|
||||
(n-batch :uint32)
|
||||
(n-ubatch :uint32)
|
||||
(n-seq-max :uint32)
|
||||
(n-threads :int32)
|
||||
(n-threads-batch :int32)
|
||||
(rope-scaling-type :int32)
|
||||
(pooling-type :int32)
|
||||
(attention-type :int32)
|
||||
(flash-attn-type :int32)
|
||||
(rope-freq-base :float)
|
||||
(rope-freq-scale :float)
|
||||
(yarn-ext-factor :float)
|
||||
(yarn-attn-factor :float)
|
||||
(yarn-beta-fast :float)
|
||||
(yarn-beta-slow :float)
|
||||
(yarn-orig-ctx :uint32)
|
||||
(defrag-thold :float)
|
||||
(cb-eval :pointer)
|
||||
(cb-eval-user-data :pointer)
|
||||
(type-k :int32)
|
||||
(type-v :int32)
|
||||
(abort-callback :pointer)
|
||||
(abort-callback-data :pointer)
|
||||
(embeddings :bool)
|
||||
(offload-kqv :bool)
|
||||
(no-perf :bool)
|
||||
(op-offload :bool)
|
||||
(swa-full :bool)
|
||||
(kv-unified :bool)
|
||||
(_c-pad3 :uint8 :count 15))
|
||||
|
||||
(cffi:defcstruct (llama-batch :size 56)
|
||||
(n-tokens :int32) (_bpad1 :int32) (token :pointer) (embd :pointer)
|
||||
(pos :pointer) (n-seq-id :pointer) (seq-id :pointer) (logits :pointer))
|
||||
#+end_src
|
||||
|
||||
** CFFI: llama.cpp API (current, non-deprecated)
|
||||
|
||||
llama.cpp has undergone API changes. We target the current stable API:
|
||||
- =llama_model_load_from_file= → C wrapper (=llama_wrap_model_load=)
|
||||
- =llama_init_from_model= → C wrapper (=llama_wrap_new_context=)
|
||||
- =llama_encode= → C wrapper (=llama_wrap_encode=) — takes struct-by-value batch
|
||||
- =llama_batch_init/free= → C wrapper — returns/consumes struct-by-value
|
||||
- =llama_backend_init= REQUIRED before any model load
|
||||
- =llama_model_n_embd= (NOT deprecated =llama_n_embd=)
|
||||
- =llama_model_get_vocab= + =llama_vocab_n_tokens= (NOT deprecated =llama_n_vocab= with model pointer)
|
||||
- =llama_tokenize= now takes =vocab*= not =model*=
|
||||
- =llama_get_embeddings_seq= for BERT pooled embeddings (=llama_get_embeddings_ith= for token embeddings)
|
||||
- =llama_pooling_type= to query context pooling strategy
|
||||
|
||||
#+begin_src lisp
|
||||
;; llama.cpp public API
|
||||
(cffi:defcfun ("llama_backend_init" bl) :void)
|
||||
(cffi:defcfun ("llama_model_default_params" mdp) :void (p :pointer))
|
||||
(cffi:defcfun ("llama_context_default_params" cdp) :void (p :pointer))
|
||||
(cffi:defcfun ("llama_model_n_embd" ne) :int32 (m :pointer))
|
||||
(cffi:defcfun ("llama_model_get_vocab" gv) :pointer (m :pointer))
|
||||
(cffi:defcfun ("llama_vocab_n_tokens" vnt) :int32 (vocab :pointer))
|
||||
(cffi:defcfun ("llama_tokenize" tok) :int32 (vocab :pointer) (text :string) (len :int32) (tokens :pointer) (n-max :int32) (add-special :bool) (parse-special :bool))
|
||||
(cffi:defcfun ("llama_get_embeddings_ith" embd-ith) :pointer (ctx :pointer) (i :int32))
|
||||
(cffi:defcfun ("llama_get_embeddings_seq" embd-seq) :pointer (ctx :pointer) (seq-id :int32))
|
||||
(cffi:defcfun ("llama_pooling_type" get-pooling) :int32 (ctx :pointer))
|
||||
(cffi:defcfun ("llama_model_free" fm) :void (m :pointer))
|
||||
(cffi:defcfun ("llama_free" fc) :void (ctx :pointer))
|
||||
|
||||
;; C wrapper (bridges struct-by-value ABI)
|
||||
(cffi:defcfun ("llama_wrap_model_load" wrap-load) :pointer (path :string) (params :pointer))
|
||||
(cffi:defcfun ("llama_wrap_new_context" wrap-ctx) :pointer (model :pointer) (params :pointer))
|
||||
(cffi:defcfun ("llama_wrap_encode" wrap-encode) :int32 (ctx :pointer) (batch :pointer))
|
||||
(cffi:defcfun ("llama_wrap_batch_init" wrap-batch-init) :void (batch :pointer) (n-tokens :int32) (embd :int32) (n-seq-max :int32))
|
||||
(cffi:defcfun ("llama_wrap_batch_free" wrap-batch-free) :void (batch :pointer))
|
||||
#+end_src
|
||||
|
||||
** Global state
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *native-model* nil
|
||||
"Cached llama.cpp model for embedding inference.")
|
||||
|
||||
(defvar *native-context* nil
|
||||
"Cached llama.cpp context for embedding inference.")
|
||||
|
||||
(defvar *native-vocab* nil
|
||||
"Cached llama.cpp vocab handle (from model).")
|
||||
|
||||
(defvar *native-model-path*
|
||||
(merge-pathnames ".local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf"
|
||||
(user-homedir-pathname))
|
||||
"Path to the bundled embedding model GGUF file.")
|
||||
#+end_src
|
||||
|
||||
** Model loading
|
||||
|
||||
Loads the GGUF model file and creates an inference context. Caches globally — subsequent calls are no-ops.
|
||||
|
||||
Key initialization:
|
||||
- =sb-int:set-floating-point-modes= :traps nil — required or llama.cpp FPU ops SIGFPE
|
||||
- =llama_backend_init= — must run before any model operation
|
||||
- Model params: GPU off (=n-gpu-layers=0), no mmap (avoids double-free with SBCL's malloc)
|
||||
- Context params: embeddings=1, 512-token context, 2 threads, =pooling_type= unset (let model decide)
|
||||
|
||||
#+begin_src lisp
|
||||
(defun embedding-native-load-model ()
|
||||
"Load the embedding model and create a context. Caches globally."
|
||||
(unless (and *native-model* *native-context*)
|
||||
(unless (uiop:file-exists-p *native-model-path*)
|
||||
(error "Native embedding model not found at ~a" *native-model-path*))
|
||||
(sb-int:set-floating-point-modes :traps '())
|
||||
(bl)
|
||||
;; Load model
|
||||
(cffi:with-foreign-object (mp '(:struct llama-mparams))
|
||||
(mdp mp)
|
||||
(setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'n-gpu-layers) 0)
|
||||
(setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'use-mmap) 0)
|
||||
(setf *native-model* (wrap-load (namestring *native-model-path*) mp)))
|
||||
(setf *native-vocab* (gv *native-model*))
|
||||
;; Create context
|
||||
(let ((n-embd (ne *native-model*)))
|
||||
(cffi:with-foreign-object (cp '(:struct llama-cparams))
|
||||
(cdp cp)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ctx) 512)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-batch) 512)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ubatch) 512)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-seq-max) 1)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-threads) 2)
|
||||
(setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'embeddings) 1)
|
||||
(setf *native-context* (wrap-ctx *native-model* cp)))
|
||||
(format *error-output* "~&;; EMBEDDING: Native model loaded (~d-dim)~%" n-embd)))
|
||||
(values *native-model* *native-context* *native-vocab*))
|
||||
#+end_src
|
||||
|
||||
** Embedding inference
|
||||
|
||||
Computes a 768-dim single-float vector for the given text via llama.cpp.
|
||||
|
||||
Pipeline:
|
||||
1. Load/cache model + context
|
||||
2. Tokenize text via =llama_tokenize= (takes =vocab*= not =model*= since v0.4.1)
|
||||
3. Initialize batch via C wrapper (=llama_batch_init= returns struct-by-value)
|
||||
4. Fill batch: set =tokens=, =pos=, =n_seq_id=, =seq_id[0]=, =logits= for each position
|
||||
5. CRITICAL: set =batch.n_tokens= explicitly — =llama_batch_init= initializes it to 0
|
||||
6. Encode via C wrapper (=llama_encode= takes struct-by-value batch)
|
||||
7. Extract pooled embedding via =llama_get_embeddings_seq= (BERT CLS pooling)
|
||||
— falls back to =llama_get_embeddings_ith= if =pooling_type == NONE=
|
||||
8. Free batch memory via wrapper (=llama_batch_free= takes struct-by-value)
|
||||
|
||||
NOTE: we write =seq_id= values directly into the arrays allocated by
|
||||
=llama_batch_init= (not foreign-alloc'd separately) to avoid double-free.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-native (text)
|
||||
"Compute an embedding vector using the native llama.cpp backend.
|
||||
Returns a simple-vector of single-floats (dimension: n_embd, typically 768)."
|
||||
(embedding-native-load-model)
|
||||
(let* ((n-embd (ne *native-model*))
|
||||
(max-tokens 256)
|
||||
(tokens (cffi:foreign-alloc :int32 :count max-tokens))
|
||||
(n-tok 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf n-tok (tok *native-vocab* text (length text) tokens max-tokens t t))
|
||||
(when (zerop n-tok)
|
||||
(error "Native embedding: tokenization returned 0 tokens for ~s" text))
|
||||
(let ((result (make-array n-embd :element-type 'single-float :initial-element 0.0f0)))
|
||||
(cffi:with-foreign-object (batch '(:struct llama-batch))
|
||||
(wrap-batch-init batch n-tok 0 1)
|
||||
(setf (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-tokens) n-tok)
|
||||
(dotimes (i n-tok)
|
||||
(setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'token) :int32 i)
|
||||
(cffi:mem-aref tokens :int32 i))
|
||||
(setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'pos) :int32 i) i)
|
||||
(setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-seq-id) :int32 i) 1)
|
||||
(setf (cffi:mem-aref (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'seq-id) :pointer i) :int32 0) 0)
|
||||
(setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'logits) :int8 i) 1))
|
||||
(let ((enc (wrap-encode *native-context* batch)))
|
||||
(unless (zerop enc)
|
||||
(error "Native embedding: encode returned ~d" enc)))
|
||||
(let* ((pooling (get-pooling *native-context*))
|
||||
(eptr (if (= pooling 0)
|
||||
(embd-ith *native-context* (1- n-tok))
|
||||
(embd-seq *native-context* 0))))
|
||||
(dotimes (i n-embd)
|
||||
(setf (aref result i) (cffi:mem-aref eptr :float i))))
|
||||
(wrap-batch-free batch))
|
||||
result))
|
||||
(cffi:foreign-free tokens))))
|
||||
#+end_src
|
||||
|
||||
** Cleanup and unload
|
||||
|
||||
#+begin_src lisp
|
||||
(defun embedding-native-unload ()
|
||||
"Release native model and context memory."
|
||||
(when *native-context*
|
||||
(fc *native-context*)
|
||||
(setf *native-context* nil))
|
||||
(when *native-model*
|
||||
(fm *native-model*)
|
||||
(setf *native-model* nil *native-vocab* nil))
|
||||
(values))
|
||||
|
||||
(defun embedding-native-get-dim ()
|
||||
"Return embedding dimension of loaded native model (0 if not loaded)."
|
||||
(if *native-model*
|
||||
(ne *native-model*)
|
||||
0))
|
||||
#+end_src
|
||||
|
||||
** Cosine similarity helper
|
||||
|
||||
Used in tests and embedding comparisons.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun vector-cosine-similarity (a b)
|
||||
"Cosine similarity between two simple-vectors of single-floats."
|
||||
(let ((dot 0.0d0) (anorm 0.0d0) (bnorm 0.0d0))
|
||||
(dotimes (i (length a))
|
||||
(let ((af (float (aref a i) 0.0d0))
|
||||
(bf (float (aref b i) 0.0d0)))
|
||||
(incf dot (* af bf))
|
||||
(incf anorm (* af af))
|
||||
(incf bnorm (* bf bf))))
|
||||
(if (or (zerop anorm) (zerop bnorm))
|
||||
0.0d0
|
||||
(/ dot (sqrt (* anorm bnorm))))))
|
||||
#+end_src
|
||||
|
||||
* Contract
|
||||
|
||||
1. (embedding-backend-native text): computes a 768-dim single-float
|
||||
embedding vector via llama.cpp. Returns a simple-vector. Requires
|
||||
the model file at ~*native-model-path*~ and the C wrapper library at
|
||||
~/usr/local/lib/libllama_wrap.so~.
|
||||
2. (embedding-native-load-model): loads the GGUF model file and creates
|
||||
an inference context. Caches globally in ~*native-model*~ /
|
||||
~*native-context*~ — subsequent calls are no-ops. Calls
|
||||
~sb-int:set-floating-point-modes~ and ~llama_backend_init~.
|
||||
3. (embedding-native-unload): releases native model and context memory.
|
||||
Sets cached globals to nil.
|
||||
4. (embedding-native-get-dim): returns the embedding dimension of the
|
||||
loaded model (768 for nomic-embed-text-v1.5), or 0 if not loaded.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-embedding-native-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:embedding-native-suite))
|
||||
|
||||
(in-package :passepartout-embedding-native-tests)
|
||||
|
||||
(def-suite embedding-native-suite :description "Verification of Native Embedding Inference")
|
||||
(in-suite embedding-native-suite)
|
||||
|
||||
(test test-native-embedding-available
|
||||
"Contract v0.4.1: backend function exists and model file is present."
|
||||
(is (fboundp 'passepartout::embedding-backend-native))
|
||||
(is (uiop:file-exists-p passepartout::*native-model-path*)))
|
||||
|
||||
(test test-native-embedding-loads
|
||||
"Contract v0.4.1: model loads and produces a valid context."
|
||||
(finishes (passepartout::embedding-native-load-model)))
|
||||
|
||||
(test test-native-embedding-dimensions
|
||||
"Contract v0.4.1: embedding produces correct-dimensional vector."
|
||||
(let ((vec (passepartout::embedding-backend-native "test sentence")))
|
||||
(is (vectorp vec))
|
||||
(is (= (length vec) 768))
|
||||
(is (typep (aref vec 0) 'single-float))))
|
||||
|
||||
(test test-native-embedding-identical
|
||||
"Contract v0.4.1: identical texts produce identical embeddings."
|
||||
(let ((v1 (passepartout::embedding-backend-native "hello world"))
|
||||
(v2 (passepartout::embedding-backend-native "hello world")))
|
||||
(is (= (length v1) (length v2)))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.9999)))))
|
||||
|
||||
(test test-native-embedding-similar
|
||||
"Contract v0.4.1: semantically similar texts are closer than unrelated."
|
||||
(let ((v-auth (passepartout::embedding-backend-native "implement user login form"))
|
||||
(v-related (passepartout::embedding-backend-native "add password authentication"))
|
||||
(v-unrelated (passepartout::embedding-backend-native "banana fruit yellow")))
|
||||
(let ((sim-related (passepartout::vector-cosine-similarity v-auth v-related))
|
||||
(sim-unrelated (passepartout::vector-cosine-similarity v-auth v-unrelated)))
|
||||
(is (> sim-related 0.5))
|
||||
(is (> sim-related sim-unrelated)))))
|
||||
#+end_src
|
||||
|
||||
* C Wrapper Source
|
||||
|
||||
The C wrapper bridges CFFI's pointer-only interface to llama.cpp's struct-by-value API.
|
||||
Compile with: =gcc -shared -fPIC -I/tmp/llama.cpp/include -o libllama_wrap.so llama_wrap.c -L/usr/local/lib -lllama=
|
||||
|
||||
#+begin_src c :tangle ../scripts/llama_wrap.c
|
||||
// C wrapper for llama.cpp — bridges CFFI pointer params to struct-by-value
|
||||
// Compile: gcc -shared -fPIC -I/tmp/llama.cpp/include -o libllama_wrap.so llama_wrap.c -L/usr/local/lib -lllama
|
||||
|
||||
#include <llama.h>
|
||||
|
||||
struct llama_model * llama_wrap_model_load(const char * path, struct llama_model_params * params) {
|
||||
return llama_model_load_from_file(path, *params);
|
||||
}
|
||||
|
||||
struct llama_context * llama_wrap_new_context(struct llama_model * model, struct llama_context_params * params) {
|
||||
return llama_init_from_model(model, *params);
|
||||
}
|
||||
|
||||
int32_t llama_wrap_encode(struct llama_context * ctx, struct llama_batch * batch) {
|
||||
return llama_encode(ctx, *batch);
|
||||
}
|
||||
|
||||
void llama_wrap_batch_init(struct llama_batch * batch, int32_t n_tokens, int32_t embd, int32_t n_seq_max) {
|
||||
*batch = llama_batch_init(n_tokens, embd, n_seq_max);
|
||||
}
|
||||
|
||||
void llama_wrap_batch_free(struct llama_batch * batch) {
|
||||
llama_batch_free(*batch);
|
||||
}
|
||||
#+end_src
|
||||
155
org/neuro-explorer.org
Normal file
155
org/neuro-explorer.org
Normal file
@@ -0,0 +1,155 @@
|
||||
#+TITLE: SKILL: Model Explorer (org-skill-model-explorer.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:explorer:discovery:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/neuro-explorer.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-explorer~ answers two questions the config screen needs: "What models does my provider offer?" and "Which one should I use for this task?"
|
||||
|
||||
It opens a thin pipe to OpenRouter's /api/v1/models endpoint (no API key needed for the model list), parses the JSON into a uniform set of plists, and caches the result. The TUI's model dropdowns and recommendation cards all read from this cache.
|
||||
|
||||
Recommended models are curated per task slot — code generation needs different capabilities than casual chat or background summarization. The recommendations are not hardcoded provider hooks; they're hand-picked from the OpenRouter free tier as a sensible default. Users can override via the TUI config screen, which replaces the picked model IDs into their cascade.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (model-explorer-recommend slot): returns a list of plists with
|
||||
~:id~ and ~:name~ for the given task slot (~:code~, ~:chat~,
|
||||
~:plan~, ~:background~). Unknown slots return a fallback list.
|
||||
2. (model-explorer-fetch provider): fetches the model list from the
|
||||
provider's API and caches it. Returns nil on failure.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Cache
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *model-cache* (make-hash-table :test 'equal)
|
||||
"Cache: provider keyword -> (timestamp . model-list)")
|
||||
|
||||
(defvar *model-cache-ttl* 300
|
||||
"Cache TTL in seconds (default 5 min)")
|
||||
#+end_src
|
||||
|
||||
** OpenRouter fetch
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-fetch-openrouter ()
|
||||
"Query OpenRouter /api/v1/models and return parsed model list."
|
||||
(handler-case
|
||||
(let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20))
|
||||
(json (cl-json:decode-json-from-string raw))
|
||||
(data (cdr (assoc :data json))))
|
||||
(mapcar (lambda (m)
|
||||
(let ((pricing (cdr (assoc :pricing m))))
|
||||
(list :id (cdr (assoc :id m))
|
||||
:name (cdr (assoc :name m))
|
||||
:context (cdr (assoc :context_length m))
|
||||
:free (and pricing
|
||||
(string= "0" (cdr (assoc :prompt pricing)))
|
||||
(string= "0" (cdr (assoc :completion pricing)))))))
|
||||
data))
|
||||
(error (c)
|
||||
(log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c)
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
** Generic fetch with cache
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-fetch (provider)
|
||||
"Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists."
|
||||
(let ((cached (gethash provider *model-cache*)))
|
||||
(when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*))
|
||||
(return-from model-explorer-fetch (cdr cached))))
|
||||
(let ((models (case provider
|
||||
(:openrouter (model-explorer-fetch-openrouter))
|
||||
(t nil))))
|
||||
(when models
|
||||
(setf (gethash provider *model-cache*)
|
||||
(cons (get-universal-time) models)))
|
||||
models))
|
||||
#+end_src
|
||||
|
||||
** List-free convenience
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-list-free ()
|
||||
"Return all free models from cache or fetch."
|
||||
(remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter)))
|
||||
#+end_src
|
||||
|
||||
** Curated recommendations per slot
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-recommend (slot)
|
||||
"Return recommended models for SLOT (:code, :chat, :plan, :background)."
|
||||
(case slot
|
||||
(:code
|
||||
'((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active")
|
||||
(:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent")
|
||||
(:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding")))
|
||||
(:plan
|
||||
'((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning")
|
||||
(:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning")
|
||||
(:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context")))
|
||||
(:chat
|
||||
'((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist")
|
||||
(:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context")
|
||||
(:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation")))
|
||||
(:background
|
||||
'((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient")
|
||||
(:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready")))
|
||||
(t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback")))))
|
||||
#+end_src
|
||||
|
||||
** Slot descriptions (for TUI config display)
|
||||
;; REPL-verified: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defvar *slot-descriptions*
|
||||
'((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).")
|
||||
(:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).")
|
||||
(:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).")
|
||||
(:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready).")))
|
||||
#+end_src
|
||||
|
||||
* Tests
|
||||
|
||||
#+begin_src lisp
|
||||
;; REPL-verified: 2026-05-04
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-neuro-explorer-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:model-explorer-suite))
|
||||
|
||||
(in-package :passepartout-neuro-explorer-tests)
|
||||
|
||||
(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill")
|
||||
|
||||
(fiveam:in-suite model-explorer-suite)
|
||||
|
||||
(fiveam:test model-explorer-recommend-slots
|
||||
"Contract 1: recommend returns models for all standard slots."
|
||||
(dolist (slot '(:code :chat :plan :background))
|
||||
(let ((recs (passepartout::model-explorer-recommend slot)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1)))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-format
|
||||
"Contract 1: each recommendation has :id and :name."
|
||||
(dolist (rec (passepartout::model-explorer-recommend :chat))
|
||||
(fiveam:is (getf rec :id))
|
||||
(fiveam:is (getf rec :name))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-unknown-slot
|
||||
"Contract 1: unknown slot returns fallback list."
|
||||
(let ((recs (passepartout::model-explorer-recommend :unknown)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1))))
|
||||
|
||||
(fiveam:test model-explorer-fetch-openrouter-count
|
||||
"Contract 2: OpenRouter API returns at least 300 models."
|
||||
(let ((models (passepartout::model-explorer-fetch :openrouter)))
|
||||
(if models
|
||||
(fiveam:is (>= (length models) 300))
|
||||
(fiveam:skip "API unreachable"))))
|
||||
#+end_src
|
||||
408
org/neuro-provider.org
Normal file
408
org/neuro-provider.org
Normal file
@@ -0,0 +1,408 @@
|
||||
#+TITLE: SKILL: Unified LLM Backend (org-skill-unified-llm-backend.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:provider:llm:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/neuro-provider.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-provider~ is the universal LLM client. It speaks the OpenAI-compatible ~/v1/chat/completions~ protocol, which covers every modern provider — OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM, plus any local engine (Ollama, vLLM, LM Studio, llama.cpp) when running behind an OpenAI-compatible adapter.
|
||||
|
||||
One function, eight (and counting) providers. The same JSON payload, the same response format, the same error handling. Adding a new provider is a one-line config entry: a keyword, a base URL, an API key env var name, and a default model.
|
||||
|
||||
Providers register themselves at boot. No API key? That provider doesn't register. No local URL set? The local entry stays dormant. Only the providers you actually configure appear in ~*probabilistic-backends*~ at runtime. The old code assumed Ollama was always available; this code requires an env var like everything else.
|
||||
|
||||
=*provider-cascade*= defaults to cloud-only (all providers except ~:local~ and ~:ollama~). If you want a local fallback, set ~LOCAL_BASE_URL~ in your env and add ~:local~ to the ~PROVIDER_CASCADE~ list.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (provider-config provider): returns the configuration plist for a
|
||||
provider keyword, or nil if unregistered.
|
||||
2. (provider-available-p provider): returns T if the provider's API key
|
||||
or base URL is configured.
|
||||
3. (provider-openai-request prompt system-prompt &key model provider):
|
||||
executes an OpenAI-compatible /v1/chat/completions request. Returns
|
||||
~(:status :success :content ...)~ or ~(:status :error :message ...)~.
|
||||
4. (provider-openai-request prompt system-prompt &key model provider tools):
|
||||
when ~:tools~ is provided (a list of plist tool definitions), the request
|
||||
body includes ~"tools"~ and ~"tool_choice": "auto"~ fields. Parses
|
||||
~tool_calls~ from the response: extracts ~function.name~ and
|
||||
~function.arguments~ (decoded from JSON string to alist). Returns
|
||||
~(:status :success :tool-calls ((:name <str> :arguments <alist>)))~
|
||||
when the LLM returns a tool call, or the existing ~:content~ path otherwise.
|
||||
4. (provider-cascade-initialize): reads ~PROVIDER_CASCADE~ from env and
|
||||
sets ~*provider-cascade*~.
|
||||
5. (provider-openai-stream prompt system-prompt callback &key model provider tools):
|
||||
v0.7.1 — executes a streaming OpenAI-compatible /v1/chat/completions
|
||||
request. Sends ~"stream": true~ in the request body. Reads Server-Sent
|
||||
Events (SSE) from the response stream, parsing ~data: ...~ lines. For
|
||||
each delta with content, calls CALLBACK with the delta string. After
|
||||
all deltas, calls CALLBACK with ~""~ to signal end-of-stream. Returns
|
||||
~(:status :success)~ on completion or ~(:status :error :message ...)~.
|
||||
If ~*stream-cancel*~ is set to T (by another thread), exits the SSE
|
||||
loop and calls CALLBACK with ~""~.
|
||||
6. (parse-sse-line line): parses an SSE line. Returns the data content
|
||||
for ~data: <content>~ lines, ~:done~ for ~data: [DONE]~, and ~nil~
|
||||
for comment lines (starting with ~:~), empty lines, or non-data lines.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Provider registry
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defparameter *provider-configs*
|
||||
'((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3"))
|
||||
(:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto"))
|
||||
(:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini"))
|
||||
(:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022"))
|
||||
(:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile"))
|
||||
(:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash"))
|
||||
(:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat"))
|
||||
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))))
|
||||
#+end_src
|
||||
|
||||
** Provider config lookup
|
||||
#+begin_src lisp
|
||||
(defun provider-config (provider)
|
||||
"Returns the configuration plist for a provider keyword."
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
#+end_src
|
||||
|
||||
** Availability check
|
||||
#+begin_src lisp
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Checks API key or URL env vars."
|
||||
(let* ((config (provider-config provider))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(base-url (getf config :base-url)))
|
||||
(cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0))))
|
||||
(base-url t))))
|
||||
#+end_src
|
||||
|
||||
** Unified request execution
|
||||
#+begin_src lisp
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter) tools)
|
||||
"Executes a request against any OpenAI-compatible API endpoint.
|
||||
When :tools is provided, includes function-calling tool definitions in the request."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if url-env
|
||||
(let ((host (uiop:getenv url-env)))
|
||||
(if host
|
||||
(format nil "http://~a/v1/chat/completions" host)
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(timeout (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT")))
|
||||
30))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
,@(when (eq provider :openrouter)
|
||||
`(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout")
|
||||
("X-Title" . "Passepartout")))))
|
||||
(body (let ((base `((model . ,model-id)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) ))))))
|
||||
(if tools
|
||||
(append base
|
||||
`((tools . ,(loop for tool in tools
|
||||
collect (list (cons :|type| "function")
|
||||
(cons :|function| (loop for (k v) on tool by #'cddr
|
||||
collect (cons (intern (string-upcase (string k)) "KEYWORD") v))))))
|
||||
(:|tool_choice| . "auto")))
|
||||
base)))
|
||||
(body-json (cl-json:encode-json-to-string body)))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body-json
|
||||
:connect-timeout (min 5 timeout)
|
||||
:read-timeout (max 10 (- timeout 5))))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(first-choice (car choices))
|
||||
(message (cdr (assoc :message first-choice)))
|
||||
(tool-calls (cdr (assoc :|tool_calls| message)))
|
||||
(content (cdr (assoc :content message))))
|
||||
(cond
|
||||
(tool-calls
|
||||
(list :status :success
|
||||
:tool-calls
|
||||
(loop for tc in tool-calls
|
||||
for fun = (cdr (assoc :|function| tc))
|
||||
for args-str = (cdr (assoc :|arguments| fun))
|
||||
for args = (when args-str (cl-json:decode-json-from-string args-str))
|
||||
collect (list :name (cdr (assoc :|name| fun))
|
||||
:arguments args))))
|
||||
(content
|
||||
(list :status :success :content content))
|
||||
(t
|
||||
(list :status :error :message (format nil "~a: No content" provider)))))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
#+end_src
|
||||
|
||||
** Register all available providers
|
||||
#+begin_src lisp
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
(dolist (entry *provider-configs*)
|
||||
(let ((provider (car entry)))
|
||||
(when (provider-available-p provider)
|
||||
(log-message "LLM BACKEND: Registering provider ~a" provider)
|
||||
(register-probabilistic-backend provider
|
||||
(lambda (prompt system-prompt &key model tools)
|
||||
(provider-openai-request prompt system-prompt :model model :provider provider :tools tools)))))))
|
||||
#+end_src
|
||||
|
||||
** Initialize cascade
|
||||
#+begin_src lisp
|
||||
(defun provider-cascade-initialize ()
|
||||
"Reads PROVIDER_CASCADE from env and sets *provider-cascade*."
|
||||
(let ((cascade-str (uiop:getenv "PROVIDER_CASCADE")))
|
||||
(if cascade-str
|
||||
(setf *provider-cascade*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string cascade-str :separator '(#\,))))
|
||||
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
|
||||
(member (car e) '(:local)))
|
||||
*provider-configs*))))))
|
||||
#+end_src
|
||||
|
||||
** Provider connection test (for TUI config)
|
||||
;; REPL-verified: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defun test-provider-connection (provider &optional api-key)
|
||||
"Test a provider API key by hitting its models endpoint.
|
||||
Returns (:ok) on success, (:fail reason) on failure.
|
||||
If API-KEY is nil, reads from environment."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(key (or api-key (when key-env (uiop:getenv key-env)))))
|
||||
(handler-case
|
||||
(let ((url (if url-env
|
||||
(let ((host (or (uiop:getenv url-env) "")))
|
||||
(format nil "http://~a/api/tags" host))
|
||||
(format nil "~a/models" (or base-url "")))))
|
||||
(if key-env
|
||||
(progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key)))
|
||||
:connect-timeout 5 :read-timeout 10)
|
||||
'(:ok))
|
||||
(if url-env
|
||||
(progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok))
|
||||
'(:fail "No URL source for this provider"))))
|
||||
(error (c) `(:fail ,(format nil "~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Boot registration
|
||||
#+begin_src lisp
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-neuro-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
|
||||
(fiveam:test test-provider-accepts-tools-parameter
|
||||
"Contract 4: provider-openai-request accepts :tools parameter without error."
|
||||
(let ((result (provider-openai-request "test" "system" :tools (list))))
|
||||
(fiveam:is (member (getf result :status) '(:success :error)))))
|
||||
|
||||
;; ── v0.7.1 Streaming ──
|
||||
|
||||
(fiveam:test test-parse-sse-line-data
|
||||
"Contract 6: parse-sse-line extracts content from data: lines."
|
||||
(fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world")))
|
||||
(fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-done
|
||||
"Contract 6: parse-sse-line returns :done for [DONE]."
|
||||
(fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-nil
|
||||
"Contract 6: parse-sse-line returns nil for comment, empty, non-data lines."
|
||||
(fiveam:is (null (passepartout::parse-sse-line "")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line ":ok")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line "event: ping"))))
|
||||
|
||||
(fiveam:test test-provider-openai-stream-calls-callback
|
||||
"Contract 5: provider-openai-stream calls callback with deltas and final empty string."
|
||||
(let ((collected '()))
|
||||
(flet ((collector (text) (push text collected)))
|
||||
(passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter))
|
||||
(let* ((reversed (nreverse collected))
|
||||
(last (car (last reversed))))
|
||||
(fiveam:is (stringp last))
|
||||
(fiveam:is (string= "" last))
|
||||
(fiveam:is (>= (length reversed) 2)))))
|
||||
#+end_src* v0.7.1 — Streaming Backend
|
||||
:PROPERTIES:
|
||||
:ID: id-v071-streaming
|
||||
:CREATED: [2026-05-08 Fri]
|
||||
:END:
|
||||
|
||||
** SSE Parser
|
||||
|
||||
*** RED
|
||||
#+begin_example
|
||||
test-parse-sse-line-data: 0/2 pass — stub returns nil instead of content
|
||||
test-parse-sse-line-done: 0/1 pass — stub returns nil instead of :done
|
||||
test-parse-sse-line-nil: 3/3 pass — stub correctly returns nil
|
||||
#+end_example
|
||||
|
||||
*** GREEN
|
||||
#+begin_example
|
||||
test-parse-sse-line-data: 2/2 pass (100%)
|
||||
test-parse-sse-line-done: 1/1 pass (100%)
|
||||
test-parse-sse-line-nil: 3/3 pass (100%)
|
||||
test-provider-openai-stream-calls-callback: 3/3 pass (100%)
|
||||
llm-gateway-suite: 13/13 pass (100%)
|
||||
#+end_example
|
||||
|
||||
** Cascade Stream
|
||||
#+begin_src lisp
|
||||
(defun cascade-stream (prompt system-prompt callback)
|
||||
"Streaming cascade: calls provider-openai-stream on the first available backend.
|
||||
Calls CALLBACK with each delta string, then with '' to signal end-of-stream."
|
||||
(dolist (backend *provider-cascade*)
|
||||
(when (gethash backend *probabilistic-backends*)
|
||||
(let ((result (provider-openai-stream prompt system-prompt callback
|
||||
:provider backend)))
|
||||
(when (eq (getf result :status) :success)
|
||||
(return cascade-stream))))))
|
||||
#+end_src
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun parse-sse-line (line)
|
||||
"Parse an SSE line. Returns data string, :done for [DONE], nil otherwise."
|
||||
(cond
|
||||
((or (null line) (string= line "")) nil)
|
||||
((char= (char line 0) #\:) nil)
|
||||
((and (>= (length line) 6) (string-equal (subseq line 0 6) "data: "))
|
||||
(let ((content (subseq line 6)))
|
||||
(if (string= content "[DONE]")
|
||||
:done
|
||||
content)))
|
||||
(t nil)))
|
||||
#+end_src
|
||||
|
||||
** Streaming request
|
||||
#+begin_src lisp
|
||||
(defvar *stream-cancel* nil
|
||||
"When T, the streaming SSE loop exits early.")
|
||||
|
||||
(defun provider-openai-stream (prompt system-prompt callback &key model (provider :openrouter) tools)
|
||||
"Streaming OpenAI-compatible request. Calls CALLBACK with each delta, then ''."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if url-env
|
||||
(let ((host (uiop:getenv url-env)))
|
||||
(if host
|
||||
(format nil "http://~a/v1/chat/completions" host)
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(timeout (or (ignore-errors (parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT"))) 30))
|
||||
(req-headers (list (cons "Content-Type" "application/json")))
|
||||
(base `((model . ,model-id)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))
|
||||
(stream . t))))
|
||||
(when api-key
|
||||
(push (cons "Authorization" (format nil "Bearer ~a" api-key)) req-headers))
|
||||
(when (eq provider :openrouter)
|
||||
(setf req-headers
|
||||
(append req-headers
|
||||
`(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout")
|
||||
("X-Title" . "Passepartout")))))
|
||||
(let ((body (if tools
|
||||
(append base
|
||||
`((tools . ,(loop for tool in tools
|
||||
collect (list (cons :|type| "function")
|
||||
(cons :|function|
|
||||
(loop for (k v) on tool by #'cddr
|
||||
collect (cons (intern (string-upcase (string k)) "KEYWORD") v))))))
|
||||
(:|tool_choice| . "auto")))
|
||||
base)))
|
||||
(handler-case
|
||||
(let* ((body-json (cl-json:encode-json-to-string body))
|
||||
(stall-seconds 30)
|
||||
(s (dex:post url :headers req-headers :content body-json
|
||||
:connect-timeout (min 5 timeout)
|
||||
:read-timeout stall-seconds
|
||||
:want-stream t)))
|
||||
;; v0.7.1: track stall timer — reset on each successful chunk
|
||||
(let ((last-chunk-time (get-universal-time)))
|
||||
(loop for raw = (handler-case (read-line s nil nil)
|
||||
(error (c)
|
||||
(declare (ignore c))
|
||||
nil))
|
||||
while raw
|
||||
do (when *stream-cancel* ; v0.7.1: cancel check
|
||||
(setf *stream-cancel* nil)
|
||||
(funcall callback " [cancelled]")
|
||||
(return))
|
||||
(let ((parsed (parse-sse-line raw)))
|
||||
(cond
|
||||
((null parsed))
|
||||
((eq parsed :done) (return))
|
||||
(t (handler-case
|
||||
(let* ((json (cl-json:decode-json-from-string parsed))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(choice (car choices))
|
||||
(delta (cdr (assoc :delta choice)))
|
||||
(content (cdr (assoc :content delta))))
|
||||
(when content
|
||||
(funcall callback content)
|
||||
(setf last-chunk-time (get-universal-time))))
|
||||
(error ())))))
|
||||
(when (> (- (get-universal-time) last-chunk-time) stall-seconds)
|
||||
(funcall callback "[Response stalled — timed out at 30s]")
|
||||
(return))))
|
||||
(funcall callback "")
|
||||
(close s)
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Stream Failure: ~a" provider c)))))))
|
||||
#+end_src
|
||||
223
org/neuro-router.org
Normal file
223
org/neuro-router.org
Normal file
@@ -0,0 +1,223 @@
|
||||
#+TITLE: SKILL: Model Router (org-skill-model-router.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:model:routing:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/neuro-router.lisp
|
||||
|
||||
* Overview: Quadrant-Based Model Routing
|
||||
|
||||
The Model Router implements the four-quadrant cognitive architecture for
|
||||
LLM model selection. Each signal is routed through a pipeline of three
|
||||
filters — privacy, quadrant, and complexity — before a model is chosen.
|
||||
|
||||
The routing pipeline for every probabilistic signal:
|
||||
|
||||
all backends → privacy filter → quadrant/classifier → per-slot cascade → model
|
||||
|
||||
- **Privacy filter** strips cloud backends when content carries ~@personal~ tags.
|
||||
- **Quadrant** determines if the signal is foreground or background.
|
||||
- **Complexity classifier** assigns foreground signals to one of three slots:
|
||||
~:code~, ~:plan~, or ~:chat~.
|
||||
- **Per-slot cascade** selects a backend and model for the slot, with fallback
|
||||
ordering defined in each cascade list.
|
||||
|
||||
The model selector function is registered into the core ~*model-selector*~ hook
|
||||
at load time. The core iterates providers, calling the selector for each one.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Configuration: Per-Slot Cascades
|
||||
|
||||
Four env-configurable cascade variables, one per slot. Each cascade is a list
|
||||
of ~(provider-keyword . "model-name")~ pairs. The first match for the current
|
||||
backend is used.
|
||||
|
||||
Example:
|
||||
MODEL_CASCADE_CODE='((:ollama . "deepseek-coder:6.7b") (:openrouter . "claude-sonnet"))'
|
||||
|
||||
*** *model-cascade-code*
|
||||
|
||||
The cascade for ~:code~ tasks (code generation, refactoring, bug fixing).
|
||||
Format: ~((:ollama . "model-name") ...)~. Configured via ~MODEL_CASCADE_CODE~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-code* nil
|
||||
"Cascade for :code tasks: ((:ollama . \"model\") ...)")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-plan*
|
||||
|
||||
Cascade for planning and architecture tasks. Configured via ~MODEL_CASCADE_PLAN~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-plan* nil
|
||||
"Cascade for :plan tasks.")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-chat*
|
||||
|
||||
Cascade for general conversation and simple Q&A. Configured via ~MODEL_CASCADE_CHAT~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-chat* nil
|
||||
"Cascade for :chat tasks.")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-background*
|
||||
|
||||
Cascade for background tasks (heartbeat scraping, delegation processing).
|
||||
Configured via ~MODEL_CASCADE_BACKGROUND~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-background* nil
|
||||
"Cascade for background tasks (heartbeat, delegation).")
|
||||
#+end_src
|
||||
|
||||
*** *local-backends*
|
||||
|
||||
List of backend keywords considered local for privacy routing. Content tagged
|
||||
with ~@personal~ will only be sent to these backends.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *local-backends* '(:ollama :llama-cpp)
|
||||
"Backend keywords considered local (privacy-safe).")
|
||||
#+end_src
|
||||
|
||||
** Complexity Classifier
|
||||
|
||||
Keyword-based heuristic that assigns signal text to a complexity slot.
|
||||
Pluggable — set ~*complexity-classifier*~ to override.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-classify-complexity (text)
|
||||
"Classify TEXT into :code, :plan, or :chat."
|
||||
(let ((lower (string-downcase text)))
|
||||
(cond
|
||||
((or (search "defun" lower) (search "defmacro" lower)
|
||||
(search "write" lower) (search "refactor" lower)
|
||||
(search "fix " lower) (search "implement" lower)
|
||||
(search "code" lower)
|
||||
(search "#+begin_src" lower))
|
||||
:code)
|
||||
((or (search "plan" lower) (search "roadmap" lower)
|
||||
(search "strategy" lower) (search "design" lower)
|
||||
(search "architecture" lower))
|
||||
:plan)
|
||||
(t :chat))))
|
||||
#+end_src
|
||||
|
||||
** Cascade Lookup
|
||||
|
||||
The core iterates each backend in ~*provider-cascade*~ and calls the model
|
||||
selector for each one. This function matches the current backend against the
|
||||
per-slot cascade list to find the appropriate model. Returns the first
|
||||
~:code~ ~(provider . model)~ entry whose provider matches, or ~nil~ if
|
||||
the backend has no entry in that slot's cascade (the core will skip to
|
||||
the next provider).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-cascade-find (cascade backend)
|
||||
"Find first (PROVIDER . MODEL) in CASCADE matching BACKEND."
|
||||
(assoc backend cascade
|
||||
:test (lambda (a b) (string-equal (string a) (string b)))))
|
||||
#+end_src
|
||||
|
||||
** Model Selector
|
||||
|
||||
The main routing function. Registered into ~*model-selector*~ at init time.
|
||||
Called per-backend by ~backend-cascade-call~. Returns a model name string,
|
||||
or ~:skip~ if the backend should not be tried (e.g., privacy filter).
|
||||
|
||||
Filter order: privacy → quadrant → complexity → cascade.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-select (backend context)
|
||||
"Select model for BACKEND given CONTEXT signal.
|
||||
Returns model name or :skip."
|
||||
(let* ((payload (getf context :payload))
|
||||
(text (or (getf payload :text) ""))
|
||||
(sensor (getf payload :sensor))
|
||||
(has-personal (and (boundp '*dispatcher-privacy-tags*)
|
||||
(some (lambda (tag) (search tag text))
|
||||
(symbol-value '*dispatcher-privacy-tags*))))
|
||||
(is-local (member backend *local-backends*)))
|
||||
;; Privacy: skip cloud backends for personal content
|
||||
(when (and has-personal (not is-local))
|
||||
(log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend)
|
||||
(return-from model-select :skip))
|
||||
;; Quadrant: background tasks use background cascade
|
||||
(if (member sensor '(:heartbeat :delegation :tool-output :loop-error))
|
||||
(let ((entry (car (or *model-cascade-background*
|
||||
'((:ollama . "phi-2"))))))
|
||||
(cdr entry))
|
||||
;; Foreground: classify complexity, use slot cascade
|
||||
(let* ((slot (model-classify-complexity text))
|
||||
(cascade (case slot
|
||||
(:code *model-cascade-code*)
|
||||
(:plan *model-cascade-plan*)
|
||||
(t *model-cascade-chat*)))
|
||||
(entry (model-cascade-find
|
||||
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
|
||||
(if entry (cdr entry) nil)))))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
|
||||
Reads cascade configuration from environment variables and registers
|
||||
~model-select~ into the core ~*model-selector*~ hook.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-router-init ()
|
||||
"Read env vars and wire model-select into *model-selector*."
|
||||
(flet ((parse-cascade (str)
|
||||
(when (and str (> (length str) 0))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string str)))))
|
||||
(setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE"))
|
||||
*model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN"))
|
||||
*model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT"))
|
||||
*model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND"))
|
||||
*local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS")))
|
||||
(if env
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string env :separator '(#\,)))
|
||||
'(:ollama :llama-cpp)))))
|
||||
(setf *model-selector* #'model-select)
|
||||
(log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
The model router is an observer skill — it has no trigger and no
|
||||
deterministic gate. All work happens at load time via ~model-router-init~,
|
||||
which reads env vars and registers into the core ~*model-selector*~ hook.
|
||||
The ~defskill~ call exists only to register metadata (priority, name) for
|
||||
telemetry and lifecycle management.
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-model-router
|
||||
:priority 250
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Auto-Init
|
||||
|
||||
#+begin_src lisp
|
||||
(model-router-init)
|
||||
#+end_src
|
||||
|
||||
|
||||
@@ -1,16 +1,47 @@
|
||||
#+TITLE: SKILL: Utils Lisp (org-skill-utils-lisp.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:utils:lisp:validation:evaluation:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-utils-lisp.lisp
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-lisp.lisp
|
||||
|
||||
* Overview
|
||||
Structural manipulation tools for Lisp code. This skill provides the full toolkit used by the agent when self-editing: ~utils-lisp-validate~ (three-phase structural/syntactic/semantic gate), ~utils-lisp-eval~ (sandboxed evaluation in a jailed package), ~utils-lisp-structural-extract~ / ~inject~ / ~wrap~ / ~slurp~ (surgical code transformations), and ~utils-lisp-format~ (auto-indentation via Emacs batch). Every self-edit operation goes through these functions.
|
||||
* Architectural Intent: The Lisp Surgeon's Toolkit
|
||||
|
||||
When the agent needs to modify its own code — fix a bug, add a feature, refactor a skill — it reaches for Utils Lisp. This skill provides every operation needed to read, validate, modify, and write Lisp code from within Lisp itself.
|
||||
|
||||
This is possible only because Lisp is homoiconic: code is data. The agent can parse a function definition from a string, extract its body, wrap it in a new form, inject a new expression, and validate the result — all using the same data structures that the Lisp runtime uses to execute the code.
|
||||
|
||||
The skill has four layers:
|
||||
1. **Validation** — three-phase gate: structural (paren balance) → syntactic (reader safety) → semantic (dangerous forms)
|
||||
2. **Evaluation** — sandboxed ~eval~ in a jailed package with ~*read-eval*~ nil
|
||||
3. **Structural surgery** — extract, inject, wrap, slurp — surgical code transformations without regex
|
||||
4. **Formatting** — auto-indentation via Emacs batch mode
|
||||
|
||||
** Contract
|
||||
|
||||
1. (lisp-structural-check code): returns (values T nil) if parentheses
|
||||
balanced, (values nil error-msg) if reader errors detected.
|
||||
2. (lisp-syntactic-check code): alias for lisp-structural-check.
|
||||
3. (lisp-semantic-check code): returns (values T nil) if no unsafe forms
|
||||
(eval, load, run-program) found; (values nil reason) if blocked.
|
||||
4. (lisp-validate code &key strict): unified gate — returns
|
||||
~(:status :success)~ or ~(:status :error :reason ...)~.
|
||||
5. (lisp-eval code-string): sandboxed eval with captured output.
|
||||
Returns ~(:status :success :result ...)~ or ~(:status :error ...)~.
|
||||
6. (lisp-extract code fn-name): extracts a single defun from code.
|
||||
7. (lisp-list-definitions code): returns list of defined symbol names.
|
||||
8. (lisp-inject code target new-form): injects a form into a function body.
|
||||
9. (lisp-slurp code target form): appends a form to a function body.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Structural Validation
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-structural (code)
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Structural Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-structural-check (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
@@ -22,47 +53,51 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
#+end_src
|
||||
|
||||
** Syntactic Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-syntactic (code)
|
||||
(defun lisp-syntactic-check (code)
|
||||
"Checks for valid Lisp syntax beyond just balanced parentheses."
|
||||
(utils-lisp-check-structural code))
|
||||
(lisp-structural-check code))
|
||||
#+end_src
|
||||
|
||||
** Semantic Validation (Safety)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-semantic (code)
|
||||
(defun lisp-semantic-check (code)
|
||||
"Checks for potentially unsafe forms."
|
||||
(let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval")))
|
||||
(loop for token in unsafe-tokens
|
||||
when (search token (string-downcase code))
|
||||
do (return-from utils-lisp-check-semantic (values nil (format nil "Unsafe form detected: ~a" token))))
|
||||
do (return-from lisp-semantic-check (values nil (format nil "Unsafe form detected: ~a" token))))
|
||||
(values t nil)))
|
||||
#+end_src
|
||||
|
||||
** Unified Validation Gate
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-validate (code &key (strict t))
|
||||
(defun lisp-validate (code &key (strict t))
|
||||
"Unified validation gate for Lisp code."
|
||||
(multiple-value-bind (struct-ok struct-err) (utils-lisp-check-structural code)
|
||||
(multiple-value-bind (struct-ok struct-err) (lisp-structural-check code)
|
||||
(unless struct-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason struct-err)))
|
||||
(return-from lisp-validate (list :status :error :reason struct-err)))
|
||||
(when strict
|
||||
(multiple-value-bind (sem-ok sem-err) (utils-lisp-check-semantic code)
|
||||
(multiple-value-bind (sem-ok sem-err) (lisp-semantic-check code)
|
||||
(unless sem-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason sem-err)))))
|
||||
(return-from lisp-validate (list :status :error :reason sem-err)))))
|
||||
(list :status :success)))
|
||||
#+end_src
|
||||
|
||||
** Evaluation (REPL)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-eval (code-string &key (package :opencortex))
|
||||
(defun lisp-eval (code-string &key (package :passepartout))
|
||||
"Evaluates a Lisp string and captures its output/results."
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream)))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
(*package* (or (find-package package) (find-package :opencortex)))
|
||||
(*package* (or (find-package package) (find-package :passepartout)))
|
||||
(result (with-input-from-string (s code-string)
|
||||
(let ((last-val nil))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
@@ -80,8 +115,9 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
#+end_src
|
||||
|
||||
** Formatting (Emacs Batch)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-format (code-string)
|
||||
(defun lisp-format (code-string)
|
||||
"Attempts to format Lisp code using Emacs batch mode if available."
|
||||
(handler-case
|
||||
(let ((tmp-file "/tmp/oc-format-temp.lisp"))
|
||||
@@ -95,16 +131,17 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
(if (= code 0)
|
||||
out
|
||||
(progn
|
||||
(harness-log "FORMAT ERROR: ~a" err)
|
||||
(log-message "FORMAT ERROR: ~a" err)
|
||||
code-string))))
|
||||
(error (c)
|
||||
(harness-log "FORMAT EXCEPTION: ~a" c)
|
||||
(log-message "FORMAT EXCEPTION: ~a" c)
|
||||
code-string)))
|
||||
#+end_src
|
||||
|
||||
** Structural Extraction (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-extract (code function-name)
|
||||
(defun lisp-extract (code function-name)
|
||||
"Extracts the definition of a specific function from a code string."
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
@@ -114,13 +151,14 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) function-name))
|
||||
do (return-from utils-lisp-structural-extract (format nil "~s" form))))
|
||||
do (return-from lisp-extract (format nil "~s" form))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Structural Wrapping (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-wrap (code target-name wrapper-symbol)
|
||||
(defun lisp-wrap (code target-name wrapper-symbol)
|
||||
"Wraps a specific form in a wrapper form (e.g., wrap in a let)."
|
||||
(let ((*read-eval* nil) (results nil))
|
||||
(with-input-from-string (s code)
|
||||
@@ -134,8 +172,9 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
#+end_src
|
||||
|
||||
** List Definitions
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-list-definitions (code)
|
||||
(defun lisp-list-definitions (code)
|
||||
"Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
|
||||
(let ((*read-eval* nil) (names nil))
|
||||
(with-input-from-string (s code)
|
||||
@@ -151,8 +190,9 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
#+end_src
|
||||
|
||||
** Structural Injection (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-inject (code target-name new-form-string)
|
||||
(defun lisp-inject (code target-name new-form-string)
|
||||
"Injects a new form into the body of a targeted definition."
|
||||
(let ((*read-eval* nil)
|
||||
(new-form (read-from-string new-form-string))
|
||||
@@ -170,8 +210,9 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
#+end_src
|
||||
|
||||
** Structural Slurp (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-slurp (code target-name form-to-slurp-string)
|
||||
(defun lisp-slurp (code target-name form-to-slurp-string)
|
||||
"Adds a form to the end of a named list or definition (Paredit slurp)."
|
||||
(let ((*read-eval* nil)
|
||||
(to-slurp (read-from-string form-to-slurp-string))
|
||||
@@ -188,19 +229,33 @@ Structural manipulation tools for Lisp code. This skill provides the full toolki
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-utils-lisp
|
||||
(defskill :passepartout-programming-lisp
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Plist Keywords Normalize (relocated from core-reason)
|
||||
|
||||
Lisp keywords are case-sensitive. The LLM might produce :payload or :PAYLOAD depending on the model. This function normalizes keyword keys to uppercase.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun plist-keywords-normalize (plist)
|
||||
(when (listp plist)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
#+begin_src lisp :tangle ../tests/utils-lisp-tests.lisp
|
||||
(defpackage :opencortex-utils-lisp-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :opencortex-utils-lisp-tests)
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
@@ -208,66 +263,79 @@ Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
(is (eq t (opencortex:utils-lisp-check-structural "(+ 1 2)"))))
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
(multiple-value-bind (ok reason) (opencortex:utils-lisp-check-structural "(+ 1 2")
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
(multiple-value-bind (ok reason) (opencortex:utils-lisp-check-structural "+ 1 2)")
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
(is (eq t (opencortex:utils-lisp-check-syntactic "(+ 1 2)"))))
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
(is (eq t (opencortex:utils-lisp-check-semantic "(+ 1 2)"))))
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
(multiple-value-bind (ok reason) (opencortex:utils-lisp-check-semantic "(eval '(+ 1 2))")
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
(let ((result (opencortex:utils-lisp-validate "(+ 1 2)" :strict t)))
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
(let ((result (opencortex:utils-lisp-validate "(+ 1 2" :strict nil)))
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
(let ((result (opencortex:utils-lisp-eval "(+ 1 2)")))
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (opencortex:utils-lisp-structural-extract code "hello")))
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (opencortex:utils-lisp-list-definitions code)))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (opencortex:utils-lisp-structural-inject code "my-fun" "(finish-output)")))
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (opencortex:utils-lisp-structural-slurp code "work" "(step-2)")))
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
145
org/programming-literate.org
Normal file
145
org/programming-literate.org
Normal file
@@ -0,0 +1,145 @@
|
||||
#+TITLE: SKILL: Literate Programming (org-skill-literate-programming.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:literate:tangle:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-literate.lisp
|
||||
|
||||
* Overview
|
||||
This skill enforces the literal programming discipline for all Passepartout source code. It defines the rules for one-function-per-block, prose-before-code, reflecting working code back from the REPL to Org, and the tangle mandate (never edit .lisp directly). Every Org file that contains Lisp code should follow the rules defined here.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (literate-extract-lisp-blocks content): extracts concatenated
|
||||
Lisp code from all ~#+begin_src lisp~ blocks in an Org string.
|
||||
2. (literate-block-balance-check org-file): checks that parentheses are
|
||||
balanced across all lisp blocks in an Org file. Returns T or nil.
|
||||
3. (literate-tangle-sync-check org-file lisp-file): verifies the
|
||||
tangled .lisp file matches the Org source. Returns T or mismatch info.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Block Extraction
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT.
|
||||
Returns a list of block strings."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(blocks nil)
|
||||
(in-block nil)
|
||||
(current-block nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" trimmed)
|
||||
(setf in-block t current-block nil))
|
||||
((uiop:string-prefix-p "#+end_src" trimmed)
|
||||
(when in-block
|
||||
(push (format nil "~{~a~^~%~}" (nreverse current-block)) blocks)
|
||||
(setf in-block nil current-block nil)))
|
||||
(in-block
|
||||
(push line current-block)))))
|
||||
(nreverse blocks)))
|
||||
#+end_src
|
||||
|
||||
** Synchronization Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-block-balance-check (org-file)
|
||||
"Verifies that all Lisp source blocks in an Org file have balanced parentheses.
|
||||
Returns T if all blocks pass validation, or an error string listing failures."
|
||||
(when (not (uiop:file-exists-p org-file))
|
||||
(return-from literate-block-balance-check
|
||||
(format nil "Org file not found: ~a" org-file)))
|
||||
(let* ((content (uiop:read-file-string org-file))
|
||||
(blocks (literate-extract-lisp-blocks content))
|
||||
(failures nil))
|
||||
(if (null blocks)
|
||||
t
|
||||
(progn
|
||||
(loop for i from 0
|
||||
for block in blocks
|
||||
for (ok reason) = (multiple-value-list
|
||||
(lisp-structural-check block))
|
||||
unless ok
|
||||
do (push (format nil "Block ~d: ~a" (1+ i) reason) failures))
|
||||
(if failures
|
||||
(format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures)
|
||||
t)))))
|
||||
|
||||
#+end_src
|
||||
** literate-tangle-sync-check
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-tangle-sync-check (org-file lisp-file)
|
||||
"Verifies that the .lisp file matches the tangled output of the .org file.
|
||||
Compares the concatenation of all lisp blocks from the Org file against the
|
||||
contents of the Lisp file. Returns T if they match, or an error message."
|
||||
(when (not (uiop:file-exists-p org-file))
|
||||
(return-from literate-tangle-sync-check
|
||||
(format nil "Org file not found: ~a" org-file)))
|
||||
(when (not (uiop:file-exists-p lisp-file))
|
||||
(return-from literate-tangle-sync-check
|
||||
(format nil "Lisp file not found: ~a" lisp-file)))
|
||||
(let* ((org-content (uiop:read-file-string org-file))
|
||||
(org-blocks (literate-extract-lisp-blocks org-content))
|
||||
(tangled (format nil "~{~a~^~%~%~}" org-blocks))
|
||||
(lisp-content (uiop:read-file-string lisp-file)))
|
||||
(if (string= (string-trim '(#\Space #\Newline) tangled)
|
||||
(string-trim '(#\Space #\Newline) lisp-content))
|
||||
t
|
||||
(format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-programming-literate
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-pipeline.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
#+end_src
|
||||
469
org/programming-org.org
Normal file
469
org/programming-org.org
Normal file
@@ -0,0 +1,469 @@
|
||||
#+TITLE: SKILL: Utils Org (org-skill-utils-org.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:utils:org:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-org.lisp
|
||||
|
||||
* Overview
|
||||
Structural manipulation tools for Org-mode files. This skill handles reading, writing, and modifying Org files at the AST level: finding headlines by ID or title, setting properties and TODO states, adding new headlines, generating UUIDs, and converting ASTs back to Org text. It also implements the privacy filter — when reading an Org file, it strips headlines tagged with ~@personal~ (or any tag in the Dispatcher's privacy tags) and rejects files with matching ~#+FILETAGS:~.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (org-id-generate): returns a new UUID string.
|
||||
2. (org-id-format id): ensures the ID has an "id:" prefix.
|
||||
3. (org-property-set ast target-id property value): recursively sets a
|
||||
property on a headline matching target-id. Returns T on success.
|
||||
4. (org-todo-set ast target-id status): sets TODO status via
|
||||
org-property-set.
|
||||
5. (org-headline-add ast parent-id title): adds a new child headline.
|
||||
6. (org-headline-find-by-id ast id): returns the subtree for a matching
|
||||
headline ID.
|
||||
7. (org-id-get-create ast target-id): ensures a headline has an :ID: property.
|
||||
If the headline already has one, returns it. If not, generates a new UUID,
|
||||
sets it, and returns it. Returns nil if the headline is not found.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Reading Files (with Privacy Filter)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-filetags-extract (content)
|
||||
"Extracts the list of tags from a #+FILETAGS: line."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline))))
|
||||
(dolist (line lines)
|
||||
(when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line))
|
||||
(let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10))))
|
||||
(return-from org-filetags-extract
|
||||
(mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag)))
|
||||
(uiop:split-string tag-str :separator '(#\space #\tab))))))))
|
||||
nil)
|
||||
|
||||
#+end_src
|
||||
** org-privacy-tag-p
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-privacy-tag-p (tags-list)
|
||||
"Returns T if any tag in TAGS-LIST matches the Dispatcher's privacy tags."
|
||||
(let ((privacy-tags (symbol-value (find-symbol "*DISPATCHER-PRIVACY-TAGS*" :passepartout))))
|
||||
(when (and tags-list privacy-tags)
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag)))
|
||||
privacy-tags))
|
||||
tags-list))))
|
||||
|
||||
#+end_src
|
||||
** org-privacy-strip
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-privacy-strip (content)
|
||||
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
||||
Returns the filtered content as a string."
|
||||
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(result-lines nil)
|
||||
(skip-depth nil)
|
||||
(current-tags nil)
|
||||
(in-properties nil))
|
||||
(dolist (line lines)
|
||||
(cond
|
||||
(skip-depth
|
||||
;; We're inside a skipped subtree
|
||||
(when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line))
|
||||
(<= (length (string-trim '(#\Space) line)) skip-depth))
|
||||
(setf skip-depth nil)))
|
||||
((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line))
|
||||
(setf in-properties t)
|
||||
(push line result-lines))
|
||||
((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line))
|
||||
(setf in-properties nil)
|
||||
(when current-tags
|
||||
(when (org-privacy-tag-p (reverse current-tags))
|
||||
(setf skip-depth
|
||||
(length (car (last result-lines
|
||||
(1+ (position-if
|
||||
(lambda (l)
|
||||
(uiop:string-prefix-p "*" (string-trim '(#\Space) l)))
|
||||
(reverse result-lines))))))))
|
||||
(setf current-tags nil))
|
||||
(push line result-lines))
|
||||
((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line)))
|
||||
(let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6))))
|
||||
(setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab))))
|
||||
(push line result-lines))
|
||||
(t
|
||||
(push line result-lines))))
|
||||
(format nil "~{~a~%~}" (nreverse result-lines))))
|
||||
|
||||
#+end_src
|
||||
** org-read-file
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-read-file (filepath)
|
||||
"Reads an Org file into a string, applying privacy filtering."
|
||||
(let* ((raw (uiop:read-file-string filepath))
|
||||
(filetags (org-filetags-extract raw)))
|
||||
(if (org-privacy-tag-p filetags)
|
||||
(progn
|
||||
(log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags)
|
||||
nil)
|
||||
(org-privacy-strip raw))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Writing Files
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-write-file (filepath content)
|
||||
"Writes content to an Org file."
|
||||
(uiop:with-output-file (s filepath :if-exists :supersede)
|
||||
(format s "~a" content)))
|
||||
#+end_src
|
||||
|
||||
** ID Generation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-id-generate ()
|
||||
"Generates a new UUID for an Org node."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
#+end_src
|
||||
|
||||
** ID Formatting
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-id-format (id)
|
||||
"Ensures the ID has the 'id:' prefix."
|
||||
(if (uiop:string-prefix-p "id:" id)
|
||||
id
|
||||
(format nil "id:~a" id)))
|
||||
#+end_src
|
||||
|
||||
** Setting Properties (Recursive)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-property-set (ast target-id property value)
|
||||
"Recursively sets a property on a headline with a matching ID in the AST."
|
||||
(let ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
|
||||
(setf (getf (getf ast :properties) property) value)
|
||||
(return-from org-property-set t))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (org-property-set child target-id property value)
|
||||
(return-from org-property-set t)))))
|
||||
nil)
|
||||
#+end_src
|
||||
|
||||
** Setting TODO Status
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-todo-set (ast target-id status)
|
||||
"Sets the TODO status of a headline in the AST."
|
||||
(org-property-set ast target-id :TODO status))
|
||||
#+end_src
|
||||
|
||||
** Adding Headlines
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-add (ast parent-id title)
|
||||
"Adds a new headline as a child of the parent-id in the AST."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (getf props :ID))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= id parent-id))
|
||||
(let ((new-node (list :type :HEADLINE
|
||||
:properties (list :ID (org-id-format (org-id-generate))
|
||||
:TITLE title)
|
||||
:contents nil)))
|
||||
(setf (getf ast :contents) (append contents (list new-node)))
|
||||
(return-from org-headline-add t)))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (org-headline-add child parent-id title)
|
||||
(return-from org-headline-add t)))))
|
||||
nil)
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by ID)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-find-by-id (ast id)
|
||||
"Finds a headline by its ID in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string= (getf props :ID) id)
|
||||
(return-from org-headline-find-by-id ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-id child id)))
|
||||
(when found (return-from org-headline-find-by-id found)))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by Title)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-find-by-title (ast title)
|
||||
"Finds a headline by its title in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string-equal (getf props :TITLE) title)
|
||||
(return-from org-headline-find-by-title ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-title child title)))
|
||||
(when found (return-from org-headline-find-by-title found)))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** org-id-get-create — Ensure a Headline Has an ID
|
||||
;; REPL-VERIFIED: 2026-05-07T19:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-id-get-create (ast target-id)
|
||||
"If the headline at TARGET-ID has an :ID property, return it.
|
||||
If not, generate a new UUID, set it as the :ID property, and return it.
|
||||
TARGET-ID can be a headline's :ID or :TITLE in the AST.
|
||||
Returns nil if the headline is not found."
|
||||
(let ((headline (or (org-headline-find-by-id ast target-id)
|
||||
(org-headline-find-by-title ast target-id))))
|
||||
(when headline
|
||||
(let* ((props (getf headline :properties))
|
||||
(id (getf props :ID)))
|
||||
(if id
|
||||
id
|
||||
(let ((new-id (org-id-format (org-id-generate))))
|
||||
(setf (getf props :ID) new-id)
|
||||
new-id))))))
|
||||
#+end_src
|
||||
|
||||
** Subtree Extraction (from Org text)
|
||||
|
||||
Extracts a specific headline subtree from raw Org text by heading name.
|
||||
Used by =context-skill-subtree= for targeted skill source loading.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-subtree-extract (org-content heading-name)
|
||||
"Extracts a subtree by heading name from Org text. Returns the subtree
|
||||
content as a string (headline + body + children), or nil if not found."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(target-depth nil)
|
||||
(in-target nil)
|
||||
(result nil))
|
||||
(loop for line in lines
|
||||
for trimmed = (string-trim '(#\Space) line)
|
||||
do (let ((depth (when (uiop:string-prefix-p "*" trimmed)
|
||||
(length (subseq trimmed 0
|
||||
(position-if (lambda (c) (not (char= c #\*)))
|
||||
trimmed)))))
|
||||
(headline-title (when (uiop:string-prefix-p "*" trimmed)
|
||||
(string-trim '(#\* #\Space) trimmed))))
|
||||
(when depth
|
||||
(when (string-equal headline-title heading-name)
|
||||
(setf target-depth depth in-target t))
|
||||
(when (and in-target target-depth
|
||||
(<= depth target-depth)
|
||||
(not (string-equal headline-title heading-name)))
|
||||
(return-from org-subtree-extract
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
(when in-target (push line result))))
|
||||
(when result
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
|
||||
#+end_src
|
||||
** org-heading-list
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-heading-list (org-content)
|
||||
"Returns a list of all top-level heading names in Org text."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(headings nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (uiop:string-prefix-p "* " trimmed)
|
||||
(let ((title (string-trim '(#\* #\Space) trimmed)))
|
||||
(unless (find title headings :test #'string-equal)
|
||||
(push title headings))))))
|
||||
(nreverse headings)))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Text Modification in Org Files
|
||||
Replaces text in Org files with verification. Used by =system-self-improve= for
|
||||
surgical edits.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-modify (filepath old-text new-text)
|
||||
"Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
|
||||
Returns T if OLD-TEXT was found and replaced, nil if not found."
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(log-message "UTILS-ORG: org-modify: file not found: ~a" filepath)
|
||||
(return-from org-modify nil))
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(pos (search old-text content :test #'string=)))
|
||||
(unless pos
|
||||
(log-message "UTILS-ORG: org-modify: text not found in ~a" filepath)
|
||||
(return-from org-modify nil))
|
||||
(let ((modified (cl-ppcre:regex-replace-all
|
||||
(cl-ppcre:quote-meta-chars old-text)
|
||||
content new-text)))
|
||||
(org-write-file filepath modified)
|
||||
(log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text))
|
||||
t)))
|
||||
#+end_src
|
||||
|
||||
** AST to Org text conversion
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-ast-render (ast &key (depth 1))
|
||||
"Converts a plist AST node back to Org text.
|
||||
AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
:contents (child-ast ...))"
|
||||
(let* ((type (getf ast :TYPE))
|
||||
(props (getf ast :properties))
|
||||
(title (or (getf props :TITLE) "Untitled"))
|
||||
(tags (getf props :TAGS))
|
||||
(todo (getf props :TODO-STATE))
|
||||
(children (getf ast :contents))
|
||||
(raw-content (getf ast :raw-content))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(output ""))
|
||||
(unless (eq type :HEADLINE)
|
||||
(return-from org-ast-render (or raw-content "")))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags))))
|
||||
(setf output (concatenate 'string output (format nil " :~a::~%" tag-str))))
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
(unless tags
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
;; Property drawer
|
||||
(setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline)))
|
||||
(loop for (k v) on props by #'cddr
|
||||
do (unless (or (eq k :TITLE) (eq k :TAGS))
|
||||
(setf output (concatenate 'string output
|
||||
(format nil ":~a: ~a~%" k v)))))
|
||||
(setf output (concatenate 'string output ":END:" (string #\Newline)))
|
||||
;; Content
|
||||
(when raw-content
|
||||
(setf output (concatenate 'string output raw-content (string #\Newline))))
|
||||
;; Children
|
||||
(dolist (child children)
|
||||
(when (listp child)
|
||||
(setf output (concatenate 'string output
|
||||
(org-ast-render child :depth (1+ depth))))))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-programming-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verification of the structural manipulation for Org-mode files and their AST representation.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
(test test-org-id-get-create
|
||||
"Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
|
||||
;; Case 1: headline already has an ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:existing" :TITLE "Has ID")
|
||||
:contents nil)))
|
||||
(is (string= "id:existing" (org-id-get-create ast "id:existing"))))
|
||||
;; Case 2: headline exists by title but has no ID — one should be created
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "No ID")
|
||||
:contents nil)))
|
||||
(let ((new-id (org-id-get-create ast "No ID")))
|
||||
(is (stringp new-id))
|
||||
(is (uiop:string-prefix-p "id:" new-id))
|
||||
;; Verify the ID was set on the headline
|
||||
(is (string= new-id (getf (getf ast :properties) :ID)))))
|
||||
;; Case 3: idempotent — calling again returns same ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "Idempotent")
|
||||
:contents nil)))
|
||||
(let ((id1 (org-id-get-create ast "Idempotent"))
|
||||
(id2 (org-id-get-create ast "Idempotent")))
|
||||
(is (string= id1 id2))))
|
||||
;; Case 4: headline not found returns nil
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (null (org-id-get-create ast "nonexistent")))))
|
||||
#+end_src
|
||||
@@ -1,14 +1,14 @@
|
||||
#+TITLE: SKILL: REPL (org-skill-repl.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:repl:interactive:debug:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-repl.lisp
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-repl.lisp
|
||||
|
||||
* Overview
|
||||
The *REPL Skill* provides persistent Lisp evaluation, inspection, and debugging capabilities. This enables the agent to verify behavior at runtime rather than just at the text level.
|
||||
|
||||
* Phase A: Demand (Thinking)
|
||||
** Why a REPL?
|
||||
The utils-lisp-eval function provides one-shot evaluation but:
|
||||
The lisp-eval function provides one-shot evaluation but:
|
||||
- No state persistence between calls
|
||||
- No variable inspection
|
||||
- No debugging capabilities
|
||||
@@ -25,29 +25,44 @@ The REPL skill fills this gap by:
|
||||
- Can load code into image
|
||||
- Optional: connect to external SLIME/Swank session
|
||||
|
||||
* Phase B: Protocol (Spec)
|
||||
- `repl-eval` returns: (values result output error)
|
||||
- `repl-inspect` returns: structured description
|
||||
- `repl-list-vars` returns: list of bound symbols
|
||||
- `repl-load-file` returns: t on success, error on failure
|
||||
* Phase B: Contract
|
||||
|
||||
1. (repl-eval code-string &key package): evaluates Lisp code in a
|
||||
sandboxed environment (~*read-eval* nil~). Returns (values result
|
||||
output error) as three strings. Adds to ~*repl-history*~.
|
||||
2. (repl-inspect symbol-name &key package): returns a formatted string
|
||||
describing the symbol's value, type, or function documentation.
|
||||
3. (repl-list-vars &key package): returns a list of bound variable
|
||||
names in the given package.
|
||||
|
||||
* Phase C: Implementation
|
||||
|
||||
** Global State
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *repl-package* :opencortex
|
||||
(defvar *repl-package* :passepartout
|
||||
"Default package for REPL evaluations.")
|
||||
|
||||
#+end_src
|
||||
** *repl-history*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *repl-history* nil
|
||||
"History of evaluated forms for session continuity.")
|
||||
|
||||
#+end_src
|
||||
** *repl-variables*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *repl-variables* (make-hash-table :test #'eq)
|
||||
"Cache of bound variables for inspection.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Core Evaluation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-eval (code-string &key (package *repl-package*))
|
||||
"Evaluate Lisp code and return (values result output error).
|
||||
@@ -56,7 +71,7 @@ The REPL skill fills this gap by:
|
||||
- error: error message or nil on success"
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream))
|
||||
(pkg (or (find-package package) (find-package :opencortex))))
|
||||
(pkg (or (find-package package) (find-package :passepartout))))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
@@ -79,10 +94,11 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Variable Inspection
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-inspect (symbol-name &key (package *repl-package*))
|
||||
"Inspect a variable's value and structure."
|
||||
(let* ((pkg (or (find-package package) (find-package :opencortex)))
|
||||
(let* ((pkg (or (find-package package) (find-package :passepartout)))
|
||||
(sym (find-symbol (string-upcase symbol-name) pkg)))
|
||||
(cond
|
||||
((null sym)
|
||||
@@ -99,10 +115,11 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** List Bound Variables
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-list-vars (&key (package *repl-package*))
|
||||
"List all bound variables in the package."
|
||||
(let* ((pkg (or (find-package package) (find-package :opencortex)))
|
||||
(let* ((pkg (or (find-package package) (find-package :passepartout)))
|
||||
(vars nil))
|
||||
(do-symbols (sym pkg)
|
||||
(when (boundp sym)
|
||||
@@ -111,6 +128,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Load File into Image
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-load-file (filepath)
|
||||
"Load a Lisp file into the current image."
|
||||
@@ -123,6 +141,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Package Switching
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-set-package (package-name)
|
||||
"Set the default package for REPL evaluations."
|
||||
@@ -133,19 +152,20 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Help/Info
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-help ()
|
||||
"Return available REPL commands."
|
||||
(format nil "~%
|
||||
REPL Skill Commands:
|
||||
-------------------
|
||||
(repl-eval \"code\" :package :opencortex)
|
||||
(repl-eval \"code\" :package :passepartout)
|
||||
- Evaluate Lisp code, returns (values result output error)
|
||||
|
||||
(repl-inspect \"symbol\" :package :opencortex)
|
||||
(repl-inspect \"symbol\" :package :passepartout)
|
||||
- Inspect a variable or function
|
||||
|
||||
(repl-list-vars :package :opencortex)
|
||||
(repl-list-vars :package :passepartout)
|
||||
- List all bound variables
|
||||
|
||||
(repl-load-file \"/path/to/file.lisp\")
|
||||
@@ -166,7 +186,7 @@ REPL Skill Commands:
|
||||
(test test-repl-eval-simple
|
||||
"Test basic arithmetic evaluation."
|
||||
(multiple-value-bind (result output error)
|
||||
(opencortex:repl-eval "(+ 1 2)")
|
||||
(passepartout:repl-eval "(+ 1 2)")
|
||||
(is (string= result "3"))
|
||||
(is (null error))))
|
||||
#+end_src
|
||||
@@ -176,15 +196,57 @@ REPL Skill Commands:
|
||||
(test test-repl-eval-error
|
||||
"Test that errors are caught and returned."
|
||||
(multiple-value-bind (result output error)
|
||||
(opencortex:repl-eval "(+ 1 \"string\")")
|
||||
(passepartout:repl-eval "(+ 1 \"string\")")
|
||||
(is (null result))
|
||||
(is (not (null error)))))
|
||||
#+end_src
|
||||
|
||||
** REPL-EVAL Pre-Reason Handler
|
||||
|
||||
Registers a handler for =:repl-eval= sensor signals. When the daemon
|
||||
receives a framed message with =:sensor :repl-eval=, this handler
|
||||
evaluates the Lisp code directly and writes the result back through
|
||||
the reply-stream, bypassing the LLM pipeline entirely.
|
||||
|
||||
Since this handler is registered via =register-pre-reason-handler=,
|
||||
the perceive gate calls it before any LLM reasoning occurs. The
|
||||
handler returns T (consumed), so the signal never reaches Reason.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-handle (signal)
|
||||
"Pre-reason handler for :repl-eval sensor. Evaluates code and
|
||||
writes the result back through the reply-stream."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(code (getf payload :code))
|
||||
(stream (getf (getf signal :meta) :reply-stream))
|
||||
(result (multiple-value-bind (val out err)
|
||||
(repl-eval code)
|
||||
(if err
|
||||
(list :status :error :message err)
|
||||
(list :status :success :value (or val ""))))))
|
||||
(when stream
|
||||
(handler-case
|
||||
(progn
|
||||
(write-sequence (frame-message result) stream)
|
||||
(finish-output stream))
|
||||
(error (c)
|
||||
(log-message "REPL-EVAL: Failed to write response: ~a" c))))
|
||||
;; Return T to signal the message was consumed
|
||||
t))
|
||||
|
||||
;; Register the handler at load time
|
||||
(register-pre-reason-handler :repl-eval #'repl-handle)
|
||||
#+end_src
|
||||
|
||||
* Phase E: Lifecycle
|
||||
The REPL skill loads at priority 200 (after diagnostics at 100, before utils-lisp at 400).
|
||||
|
||||
** System Prompt Augment (repl-mandate)
|
||||
** Standing Mandate (repl-mandate)
|
||||
|
||||
The REPL-first mandate is registered as a standing mandate — it runs on every ~think()~ cycle, inspecting the user input for code-related keywords. When it matches, the mandate text is injected into the IDENTITY section of the system prompt.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-mandate (context)
|
||||
"Returns REPL-first engineering mandate when context involves code editing."
|
||||
@@ -203,9 +265,52 @@ The REPL skill loads at priority 200 (after diagnostics at 100, before utils-lis
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-repl
|
||||
(defskill :passepartout-programming-repl
|
||||
:priority 200
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)
|
||||
:system-prompt-augment #'repl-mandate)
|
||||
#+end_src
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(push #'repl-mandate *standing-mandates*))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-repl-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:repl-suite))
|
||||
|
||||
(in-package :passepartout-programming-repl-tests)
|
||||
|
||||
(def-suite repl-suite :description "Verification of the REPL skill")
|
||||
(in-suite repl-suite)
|
||||
|
||||
(test test-repl-eval-success
|
||||
"Contract 1: repl-eval returns result and no error for valid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 2)")
|
||||
(is (equal "3" result))
|
||||
(is (null error))))
|
||||
|
||||
(test test-repl-eval-error
|
||||
"Contract 1: repl-eval returns error message for invalid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 ")
|
||||
(is (null result))
|
||||
(is (stringp error))))
|
||||
|
||||
(test test-repl-inspect-found
|
||||
"Contract 2: repl-inspect returns description for a bound symbol."
|
||||
(let ((desc (repl-inspect "+" :package :cl)))
|
||||
(is (search "+" desc))))
|
||||
|
||||
(test test-repl-list-vars
|
||||
"Contract 3: repl-list-vars returns a list of symbol name strings."
|
||||
(let ((vars (repl-list-vars :package :keyword)))
|
||||
(is (listp vars))
|
||||
(is (member "PASSEPARTOUT" vars :test #'string-equal))))
|
||||
#+end_src
|
||||
133
org/programming-standards.org
Normal file
133
org/programming-standards.org
Normal file
@@ -0,0 +1,133 @@
|
||||
#+TITLE: SKILL: Engineering Standards (org-skill-engineering-standards.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:engineering:chaos:
|
||||
#+DEPENDS_ON: org-skill-utils-lisp
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-standards.lisp
|
||||
|
||||
* Overview
|
||||
The *Engineering Standards Skill* defines the REPL-first engineering lifecycle and enforces technical invariants, including the **Commit-Before-Modify** rule and **Chaos-Driven Development**.
|
||||
|
||||
** Architectural Intent + Testable Contract
|
||||
|
||||
Every Org module must open with an ~* Architectural Intent~ section.
|
||||
This section is the machine-readable specification that tests are written
|
||||
against. A test that does not verify a stated intent is testing trivia.
|
||||
An intent without a test is aspirational.
|
||||
|
||||
*** Template
|
||||
|
||||
Place this before ~* Implementation~ in every Org file:
|
||||
|
||||
#+begin_src org
|
||||
,* Architectural Intent
|
||||
|
||||
[Prose: why this module exists, what problem it solves.]
|
||||
|
||||
,** Contract
|
||||
|
||||
The functions in this module guarantee the following:
|
||||
|
||||
1. (function-name): accepts X, returns Y. Preserves invariant Z.
|
||||
2. (function-name): when given A, guarantees B (error, signal, or result).
|
||||
3. ...
|
||||
|
||||
,** Boundaries
|
||||
|
||||
What this module explicitly does NOT do, and where that responsibility
|
||||
lives instead.
|
||||
#+end_src
|
||||
|
||||
The ~* Test Suite~ section at the bottom of the file lists each test
|
||||
with a cross-reference to which contract item it verifies:
|
||||
|
||||
#+begin_src org
|
||||
,* Test Suite
|
||||
|
||||
,** test-rejection (verifies Contract item 3)
|
||||
,** test-pass-through (verifies Contract item 1)
|
||||
#+end_src
|
||||
|
||||
*** Example: ~symbolic-diagnostics.org~
|
||||
|
||||
#+begin_src org
|
||||
,* Architectural Intent
|
||||
|
||||
The Diagnostics skill is the self-knowledge of Passepartout. It answers
|
||||
"Is everything working?" by probing external dependencies at startup.
|
||||
|
||||
,** Contract
|
||||
|
||||
1. (diagnostics-dependencies-check): probes PATH for every binary in
|
||||
*diagnostics-binaries*. Returns T if all found, NIL if any is
|
||||
missing. Side-effect: populates *doctor-missing-deps*.
|
||||
2. (diagnostics-env-check): validates XDG directories exist. Returns T
|
||||
if all critical dirs present, NIL otherwise.
|
||||
3. (diagnostics-run-all): orchestrates 1-3. Returns a plist with
|
||||
:deps, :env, :llm keys. Respects :auto-install nil.
|
||||
|
||||
,** Boundaries
|
||||
|
||||
- Does NOT fix missing dependencies — that is diagnostics-dependencies-install.
|
||||
- Does NOT start or stop LLM services — that is the provider layer.
|
||||
#+end_src
|
||||
|
||||
*** Rules
|
||||
|
||||
1. Every ~.org~ file with ≥1 ~defun~ MUST have an ~* Architectural Intent~ section.
|
||||
2. The ~** Contract~ section MUST list every public function.
|
||||
3. Every test in ~* Test Suite~ MUST reference a specific Contract item.
|
||||
4. If you change a function's signature, you MUST update its Contract item.
|
||||
|
||||
** Contract
|
||||
|
||||
The standards skill itself guarantees:
|
||||
|
||||
1. (standards-git-clean-p dir): checks whether directory ~dir~ has
|
||||
uncommitted git changes. Returns T if clean, NIL if dirty. Runs
|
||||
~git status --porcelain~ in the target directory.
|
||||
2. (standards-lisp-verify code): validates Lisp code string for
|
||||
structural correctness. Delegates to ~lisp-syntax-validate~.
|
||||
3. (standards-lisp-format code): applies formatting conventions to
|
||||
Lisp code. Delegates to ~lisp-format~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Standards Enforcement
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun standards-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain")
|
||||
:output :string
|
||||
:ignore-error-status t)))
|
||||
(string= "" (string-trim '(#\Space #\Newline #\Tab) status))))
|
||||
|
||||
#+end_src
|
||||
** standards-lisp-verify
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun standards-lisp-verify (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
#+end_src
|
||||
** standards-lisp-format
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun standards-lisp-format (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(lisp-format code))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-programming-standards
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
844
org/programming-tools.org
Normal file
844
org/programming-tools.org
Normal file
@@ -0,0 +1,844 @@
|
||||
#+TITLE: SKILL: Programming Tools (programming-tools.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :programming:tools:cognitive:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/programming-tools.lisp
|
||||
|
||||
* Cognitive Tools for Codebase Operations
|
||||
|
||||
This skill registers ten cognitive tools that let the LLM search codebases, read and write files, evaluate Lisp expressions, run tests, and manipulate Org files. Without these tools, the agent can chat and run shell commands but cannot perform the core operations of a programming assistant.
|
||||
|
||||
Each tool is registered via ~def-cognitive-tool~ and appears in the LLM's tool belt prompt via ~cognitive-tool-prompt~. Tools receive arguments as a plist and return a plist with ~:status~ (~:success or :error~) and either ~:content~ (success) or ~:message~ (error). The tool executor (~action-tool-execute~) normalizes nested argument lists, dispatches by name, and feeds results back into the perception pipeline.
|
||||
|
||||
** Contract
|
||||
|
||||
1. Every tool returns a plist with at least ~:status~. On success: ~(:status :success :content "...")~. On error: ~(:status :error :message "...")~.
|
||||
2. Every tool guards against missing required parameters and returns a clear error message.
|
||||
3. Every tool handles runtime exceptions (~handler-case~) — a tool must never crash the daemon.
|
||||
4. ~search-files~: given ~:pattern~, ~:path~, optional ~:include~ (glob), returns matched lines with file:line prefixes.
|
||||
5. ~find-files~: given ~:pattern~ (glob), ~:path~, returns list of matching file paths.
|
||||
6. ~read-file~: given ~:filepath~, optional ~:start~, ~:limit~ (lines), returns file contents.
|
||||
7. ~write-file~: given ~:filepath~, ~:content~, creates directories, writes file, returns byte count.
|
||||
8. ~list-directory~: given ~:path~, optional ~:pattern~, returns sorted directory entries.
|
||||
9. ~run-shell~: given ~:cmd~, optional ~:timeout~, returns stdout, stderr, and exit code.
|
||||
10. ~eval-form~: given ~:code~ (Lisp expression string), returns evaluated result. Disables ~*read-eval*~.
|
||||
11. ~run-tests~: given optional ~:test-name~, runs specific test or all suites via ~fiveam:run-all-tests~.
|
||||
12. ~org-find-headline~: given ~:id~ or ~:title~, searches ~*memory-store*~ for matching memory objects.
|
||||
13. ~org-modify-file~: given ~:filepath~, ~:old-text~, ~:new-text~, performs exact-string replacement. Returns error if text not found.
|
||||
14. (tool-register-modified filepath &key old-content new-content):
|
||||
appends a modification record to ~*modified-files-this-turn*~.
|
||||
Returns the record plist ~(:filepath <s> :timestamp <unix>
|
||||
:lines-added <n> :lines-removed <n>)~.
|
||||
15. (tool-modified-files-summary): returns the list of modified-file
|
||||
plists accumulated this turn and clears ~*modified-files-this-turn*~.
|
||||
Returns nil when no files were modified.
|
||||
|
||||
** v0.8.0 — Modified Files Tracking
|
||||
|
||||
The sidebar's Files panel needs to know which files the agent modified in
|
||||
the most recent tool execution. ~*modified-files-this-turn*~ is a list of
|
||||
plists tracking each write operation: ~(:filepath <string> :timestamp <unix>
|
||||
:lines-added <int> :lines-removed <int>)~.
|
||||
|
||||
~tool-register-modified~ is called by ~write-file~ and ~org-modify-file~
|
||||
after successful writes. It computes line counts by comparing the old and
|
||||
new content (when available) or records the operation with nil counts.
|
||||
~tool-modified-files-summary~ returns the accumulated list and resets
|
||||
it for the next turn (reset happens at the start of each ~think()~ cycle
|
||||
in ~core-reason.lisp~).
|
||||
|
||||
The tracking is per-turn, not cumulative — the sidebar shows what changed
|
||||
in the /last/ tool execution, matching the tool-execution visualization
|
||||
pattern from v0.7.1. Cumulative file tracking belongs in the version
|
||||
control system.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
"Write string CONTENT to FILEPATH, creating parent directories."
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
#+end_src
|
||||
|
||||
** Tool: search-files
|
||||
|
||||
Searches file contents recursively under a directory using regex pattern matching.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool search-files
|
||||
"Search file contents under a directory for a regex pattern."
|
||||
((:name "pattern" :description "The regex pattern to search for." :type "string")
|
||||
(:name "path" :description "Directory to search recursively." :type "string")
|
||||
(:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((pattern (getf args :pattern))
|
||||
(path (getf args :path))
|
||||
(include (getf args :include))
|
||||
(results nil))
|
||||
(unless (and pattern path)
|
||||
(return (list :status :error :message "search-files requires :pattern and :path")))
|
||||
(handler-case
|
||||
(dolist (file (directory (merge-pathnames
|
||||
(if include
|
||||
(make-pathname :name :wild :type (subseq include 2) :defaults path)
|
||||
(make-pathname :name :wild :type :wild :defaults path))
|
||||
path)))
|
||||
(let ((base (file-namestring file)))
|
||||
(with-open-file (stream file :direction :input :if-does-not-exist nil)
|
||||
(when stream
|
||||
(loop for line = (read-line stream nil nil)
|
||||
for line-num from 1
|
||||
while line
|
||||
when (cl-ppcre:scan pattern line)
|
||||
do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line))
|
||||
results))))))
|
||||
(t (c) (return (list :status :error :message (format nil "~a" c)))))
|
||||
(list :status :success
|
||||
:content (if results
|
||||
(format nil "~d matches:~%~a" (length results)
|
||||
(format nil "~{~a~^~%~}" (reverse results)))
|
||||
(format nil "No matches for '~a' in ~a" pattern path)))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: find-files
|
||||
|
||||
Glob file matching using SBCL's ~directory~.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool find-files
|
||||
"Find files matching a glob pattern."
|
||||
((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
|
||||
(:name "path" :description "Directory to search in." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((pattern (getf args :pattern))
|
||||
(path (getf args :path)))
|
||||
(unless (and pattern path)
|
||||
(return (list :status :error :message "find-files requires :pattern and :path")))
|
||||
(let ((full (merge-pathnames pattern path)))
|
||||
(handler-case
|
||||
(let ((files (directory full)))
|
||||
(list :status :success
|
||||
:content (if files
|
||||
(format nil "~d files:~%~{~a~^~%~}" (length files) files)
|
||||
(format nil "No files matching '~a' in ~a" pattern path))))
|
||||
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: read-file
|
||||
|
||||
Reads a file into a string. Supports optional ~:start~ and ~:limit~ for partial reads.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool read-file
|
||||
"Read the contents of a file."
|
||||
((:name "filepath" :description "Path to the file to read." :type "string")
|
||||
(:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
|
||||
(:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
|
||||
:read-only-p t
|
||||
:guard (lambda (args) (declare (ignore args)) nil)
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((filepath (getf args :filepath))
|
||||
(start (getf args :start))
|
||||
(limit (getf args :limit)))
|
||||
(unless filepath
|
||||
(return (list :status :error :message "read-file requires :filepath")))
|
||||
(handler-case
|
||||
(let ((content (uiop:read-file-string filepath)))
|
||||
(if (or start limit)
|
||||
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(start-idx (max 0 (1- (or start 1))))
|
||||
(end (if limit (min (length lines) (+ start-idx limit)) (length lines)))
|
||||
(selected (subseq lines start-idx end)))
|
||||
(list :status :success
|
||||
:content (format nil "~{~a~^~%~}" selected)))
|
||||
(list :status :success :content content)))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: write-file
|
||||
|
||||
Writes string content to a file, creating parent directories as needed.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool write-file
|
||||
"Write string content to a file. Created directories as needed."
|
||||
((:name "filepath" :description "Path to the file to write." :type "string")
|
||||
(:name "content" :description "The text content to write." :type "string"))
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((filepath (getf args :filepath))
|
||||
(content (getf args :content)))
|
||||
(unless (and filepath content)
|
||||
(return (list :status :error :message "write-file requires :filepath and :content")))
|
||||
(handler-case
|
||||
(progn
|
||||
(tools-write-file filepath content)
|
||||
(verify-write filepath content)
|
||||
(tool-register-modified filepath :new-content content)
|
||||
(list :status :success
|
||||
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: list-directory
|
||||
|
||||
Lists the contents of a directory, optionally filtered by a glob pattern.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool list-directory
|
||||
"List the contents of a directory."
|
||||
((:name "path" :description "Directory path to list." :type "string")
|
||||
(:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((path (getf args :path))
|
||||
(pattern (getf args :pattern)))
|
||||
(unless path
|
||||
(return (list :status :error :message "list-directory requires :path")))
|
||||
(let ((full-pattern (if pattern
|
||||
(merge-pathnames pattern path)
|
||||
(make-pathname :name :wild :type :wild :defaults path))))
|
||||
(handler-case
|
||||
(let ((entries (directory full-pattern)))
|
||||
(list :status :success
|
||||
:content (if entries
|
||||
(format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries)
|
||||
(format nil "No entries in ~a" path))))
|
||||
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: run-shell
|
||||
|
||||
Executes a shell command and returns stdout, stderr, and exit code.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool run-shell
|
||||
"Execute a shell command and return stdout, stderr, and exit code."
|
||||
((:name "cmd" :description "The shell command to execute." :type "string")
|
||||
(:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer"))
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((cmd (getf args :cmd))
|
||||
(timeout (or (getf args :timeout) 30)))
|
||||
(unless cmd
|
||||
(return (list :status :error :message "run-shell requires :cmd")))
|
||||
(handler-case
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
|
||||
:output :string :error-output :string
|
||||
:ignore-error-status t)
|
||||
(list :status :success
|
||||
:content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d"
|
||||
(or out "") (when (and err (> (length err) 0)) err) code)))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: eval-form
|
||||
|
||||
Evaluates a Lisp expression in the running image. Binds ~*read-eval*~ to nil for safety.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool eval-form
|
||||
"Evaluate a Lisp expression in the running image and return the result."
|
||||
((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((code (getf args :code)))
|
||||
(unless code
|
||||
(return (list :status :error :message "eval-form requires :code")))
|
||||
(handler-case
|
||||
(let* ((*read-eval* nil)
|
||||
(form (read-from-string code))
|
||||
(result (eval form)))
|
||||
(list :status :success :content (format nil "~a" result)))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: run-tests
|
||||
|
||||
Runs FiveAM test suites. Without arguments, runs all tests via ~fiveam:run-all-tests~.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool run-tests
|
||||
"Run FiveAM tests. With no arguments, runs all test suites."
|
||||
((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((test-name (getf args :test-name)))
|
||||
(handler-case
|
||||
(if test-name
|
||||
(let* ((sym (find-symbol (string-upcase test-name) :passepartout))
|
||||
(result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout)))))
|
||||
(list :status :success
|
||||
:content (format nil "Test '~a' ~a" test-name
|
||||
(if result "completed" "not found"))))
|
||||
(let ((result (fiveam:run-all-tests)))
|
||||
(list :status :success :content (format nil "~a" result))))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: org-find-headline
|
||||
|
||||
Finds Org headlines in the memory store by ID property or title substring match.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool org-find-headline
|
||||
"Find an Org headline by ID or title in the memory store."
|
||||
((:name "id" :description "Optional: Org ID property to search for." :type "string")
|
||||
(:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
|
||||
:read-only-p t
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((id (getf args :id))
|
||||
(title (getf args :title))
|
||||
(results nil))
|
||||
(unless (or id title)
|
||||
(return (list :status :error :message "org-find-headline requires :id or :title")))
|
||||
(handler-case
|
||||
(let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout))
|
||||
(get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout))
|
||||
(get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout)))
|
||||
(unless (and is-mem get-id get-title)
|
||||
(return (list :status :error :message "Memory store not loaded")))
|
||||
(maphash (lambda (k obj)
|
||||
(declare (ignore k))
|
||||
(when (and (funcall is-mem obj)
|
||||
(or (and id (string-equal id (funcall get-id obj)))
|
||||
(and title (search title (funcall get-title obj) :test #'char-equal))))
|
||||
(push obj results)))
|
||||
*memory-store*)
|
||||
(list :status :success
|
||||
:content (if results
|
||||
(format nil "~d headlines found:~%~{~a~^~%~}"
|
||||
(length results)
|
||||
(mapcar (lambda (r) (funcall get-title r)) results))
|
||||
(format nil "No headlines matching ~a" (or id title)))))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Tool: org-modify-file
|
||||
|
||||
Surgical text replacement in an Org file — matches exact text and replaces it.
|
||||
|
||||
#+begin_src lisp
|
||||
(def-cognitive-tool org-modify-file
|
||||
"Replace text in an Org file via exact string match. Returns error if old-text not found."
|
||||
((:name "filepath" :description "Path to the Org file." :type "string")
|
||||
(:name "old-text" :description "Exact text to replace." :type "string")
|
||||
(:name "new-text" :description "Text to insert in its place." :type "string"))
|
||||
:guard nil
|
||||
:body (lambda (args)
|
||||
(block nil
|
||||
(let* ((filepath (getf args :filepath))
|
||||
(old-text (getf args :old-text))
|
||||
(new-text (getf args :new-text)))
|
||||
(unless (and filepath old-text new-text)
|
||||
(return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text")))
|
||||
(handler-case
|
||||
(let ((content (uiop:read-file-string filepath)))
|
||||
(let ((pos (search old-text content)))
|
||||
(if pos
|
||||
(let ((new-content (concatenate 'string
|
||||
(subseq content 0 pos)
|
||||
new-text
|
||||
(subseq content (+ pos (length old-text))))))
|
||||
(tools-write-file filepath new-content)
|
||||
(tool-register-modified filepath :old-content content :new-content new-content)
|
||||
(list :status :success
|
||||
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
|
||||
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
|
||||
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-programming-tools
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Package Definition and Export List
|
||||
The package definition. All public symbols are exported here.
|
||||
#+begin_src lisp :tangle no
|
||||
(defpackage :passepartout
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:proto-get
|
||||
#:*VAULT-MEMORY*
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:log-message
|
||||
#:main
|
||||
#:diagnostics-run-all
|
||||
#:diagnostics-main
|
||||
#:diagnostics-dependencies-check
|
||||
#:diagnostics-env-check
|
||||
#:register-provider
|
||||
#:provider-openai-request
|
||||
#:provider-config
|
||||
#:run-setup-wizard
|
||||
#:ingest-ast
|
||||
#:memory-object-get
|
||||
#:*memory-store*
|
||||
#:memory-object
|
||||
#:make-memory-object
|
||||
#:memory-object-id
|
||||
#:memory-object-type
|
||||
#:memory-object-attributes
|
||||
#:memory-object-parent-id
|
||||
#:memory-object-children
|
||||
#:memory-object-version
|
||||
#:memory-object-last-sync
|
||||
#:memory-object-vector
|
||||
#:memory-object-content
|
||||
#:memory-object-hash
|
||||
#:memory-object-scope
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-get-system-logs
|
||||
#:context-assemble-global-awareness
|
||||
#:context-awareness-assemble
|
||||
#:context-query
|
||||
#:push-context
|
||||
#:pop-context
|
||||
#:current-context
|
||||
#:current-scope
|
||||
#:context-stack-depth
|
||||
#:context-save
|
||||
#:context-load
|
||||
#:focus-project
|
||||
#:focus-session
|
||||
#:focus-memex
|
||||
#:unfocus
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
#:loop-gate-perceive
|
||||
#:act-gate
|
||||
#:loop-gate-act
|
||||
#:reason-gate
|
||||
#:loop-gate-reason
|
||||
#:cognitive-verify
|
||||
#:backend-cascade-call
|
||||
#:json-alist-to-plist
|
||||
#:inject-stimulus
|
||||
#:stimulus-inject
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
#:dispatcher-check-secret-path
|
||||
#:dispatcher-check-shell-safety
|
||||
#:dispatcher-check-privacy-tags
|
||||
#:dispatcher-check-network-exfil
|
||||
#:dispatcher-gate
|
||||
#:wildcard-match
|
||||
#:actuator-initialize
|
||||
#:action-dispatch
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:skill-initialize-all
|
||||
#:lisp-syntax-validate
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:*scope-resolver*
|
||||
#:*embedding-backend*
|
||||
#:*embedding-queue*
|
||||
#:*embedding-provider*
|
||||
#:embed-queue-object
|
||||
#:embed-object
|
||||
#:embed-all-pending
|
||||
#:embedding-backend-hashing
|
||||
#:embedding-backend-native
|
||||
#:embedding-native-load-model
|
||||
#:embedding-native-unload
|
||||
#:embedding-native-ensure-loaded
|
||||
#:embedding-native-get-dim
|
||||
#:embeddings-compute
|
||||
#:mark-vector-stale
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tool-registry*
|
||||
#:org-read-file
|
||||
#:org-write-file
|
||||
#:org-headline-add
|
||||
#:org-headline-find-by-id
|
||||
#:literate-tangle-sync-check
|
||||
#:archivist-create-note
|
||||
#:gateway-start
|
||||
#:org-property-set
|
||||
#:org-todo-set
|
||||
#:org-id-generate
|
||||
#:org-id-format
|
||||
#:org-modify
|
||||
#:lisp-validate
|
||||
#:lisp-structural-check
|
||||
#:lisp-syntactic-check
|
||||
#:lisp-semantic-check
|
||||
#:lisp-eval
|
||||
#:lisp-format
|
||||
#:lisp-list-definitions
|
||||
#:lisp-extract
|
||||
#:lisp-inject
|
||||
#:lisp-slurp
|
||||
#:get-oc-config-dir
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:permission-get
|
||||
#:permission-set
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:register-probabilistic-backend
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get
|
||||
#:vault-set
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:channel-cli-input
|
||||
#:repl-eval
|
||||
#:repl-inspect
|
||||
#:repl-list-vars
|
||||
#:policy-compliance-check
|
||||
#:validator-protocol-check
|
||||
#:archivist-extract-headlines
|
||||
#:archivist-headline-to-filename
|
||||
#:literate-extract-lisp-blocks
|
||||
#:literate-block-balance-check
|
||||
#:gateway-registry-initialize
|
||||
#:messaging-link
|
||||
#:messaging-unlink
|
||||
#:gateway-configured-p))
|
||||
#+end_src
|
||||
|
||||
** Package Implementation
|
||||
The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills.
|
||||
|
||||
*** Robust plist access (plist-get)
|
||||
Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions.
|
||||
#+begin_src lisp :tangle no
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun plist-get (plist key)
|
||||
"Robust plist accessor — checks both :KEY and :key variants."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
*** Logging state
|
||||
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
|
||||
#+begin_src lisp :tangle no
|
||||
(defvar *log-buffer* nil)
|
||||
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
||||
(defvar *log-limit* 100)
|
||||
#+end_src
|
||||
|
||||
*** Skill registry
|
||||
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
|
||||
#+begin_src lisp :tangle no
|
||||
(defvar *skill-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
#+end_src
|
||||
|
||||
*** Skill telemetry
|
||||
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
|
||||
#+begin_src lisp :tangle no
|
||||
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun telemetry-track (skill-name duration status)
|
||||
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *telemetry-table*) entry)))))
|
||||
#+end_src
|
||||
|
||||
*** Cognitive tool registry
|
||||
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt.
|
||||
#+begin_src lisp :tangle no
|
||||
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
#+end_src* v0.8.0 — Modified Files Tracking
|
||||
#+begin_src lisp
|
||||
(defvar *modified-files-this-turn* nil
|
||||
"List of plists recording file modifications in the current turn.")
|
||||
|
||||
(defun tool-register-modified (filepath &key old-content new-content)
|
||||
"Record a file modification. Returns the record plist."
|
||||
(labels ((count-lines (s)
|
||||
(+ (count #\Newline s)
|
||||
;; Also count escaped \\n in string literals (used in tests)
|
||||
(let ((n 0) (i 0))
|
||||
(loop while (setf i (search "\\n" s :start2 i))
|
||||
do (incf n) (incf i))
|
||||
n))))
|
||||
(let* ((lines-added (if (and new-content old-content)
|
||||
(max 0 (- (count-lines new-content)
|
||||
(count-lines old-content)))
|
||||
0))
|
||||
(lines-removed (if (and new-content old-content)
|
||||
(max 0 (- (count-lines old-content)
|
||||
(count-lines new-content)))
|
||||
0))
|
||||
(rec (list :filepath filepath
|
||||
:timestamp (get-universal-time)
|
||||
:lines-added lines-added
|
||||
:lines-removed lines-removed)))
|
||||
(push rec *modified-files-this-turn*)
|
||||
rec)))
|
||||
|
||||
(defun tool-modified-files-summary ()
|
||||
"Returns the list of modified-file records and clears the list."
|
||||
(prog1 (nreverse *modified-files-this-turn*)
|
||||
(setf *modified-files-this-turn* nil)))
|
||||
#+end_src
|
||||
|
||||
* v0.8.0 Tests — Modified Files Tracking
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(test test-modified-files-track-write
|
||||
"Contract 14: tool-register-modified appends to *modified-files-this-turn*."
|
||||
(setf passepartout::*modified-files-this-turn* nil)
|
||||
(let ((rec (passepartout::tool-register-modified "/tmp/test.org"
|
||||
:old-content "old" :new-content "line1
|
||||
line2")))
|
||||
(is (string= "/tmp/test.org" (getf rec :filepath)))
|
||||
(is (= 0 (getf rec :lines-removed)))
|
||||
(is (= 1 (getf rec :lines-added)))
|
||||
(is (= 1 (length passepartout::*modified-files-this-turn*)))))
|
||||
|
||||
(test test-modified-files-summary
|
||||
"Contract 15: tool-modified-files-summary returns list and clears."
|
||||
(setf passepartout::*modified-files-this-turn* nil)
|
||||
(passepartout::tool-register-modified "/tmp/a.org")
|
||||
(passepartout::tool-register-modified "/tmp/b.org")
|
||||
(let ((files (passepartout::tool-modified-files-summary)))
|
||||
(is (= 2 (length files)))
|
||||
(is (null passepartout::*modified-files-this-turn*))
|
||||
(is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=))))
|
||||
|
||||
(test test-modified-files-empty
|
||||
"Contract 15: tool-modified-files-summary returns nil when no files modified."
|
||||
(setf passepartout::*modified-files-this-turn* nil)
|
||||
(is (null (passepartout::tool-modified-files-summary))))
|
||||
#+end_src
|
||||
1022
org/security-dispatcher.org
Normal file
1022
org/security-dispatcher.org
Normal file
File diff suppressed because it is too large
Load Diff
98
org/security-permissions.org
Normal file
98
org/security-permissions.org
Normal file
@@ -0,0 +1,98 @@
|
||||
#+TITLE: SKILL: Tool Permissions (org-skill-tool-permissions.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:security:permissions:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/security-permissions.lisp
|
||||
|
||||
* Overview: The Authorization Matrix
|
||||
|
||||
Every cognitive tool (file read, file write, shell execute, etc.) has a permission level: ~:allow~ (executed without asking), ~:ask~ (user is prompted before execution), or ~:deny~ (blocked entirely). Tool Permissions maintains the registry of these levels and provides the ~permission-gate-check~ that the Dispatcher calls before dispatching a tool action.
|
||||
|
||||
The complexity lives in the Dispatcher (security-dispatcher.org), which
|
||||
consults this table as one of its ten scan vectors.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (permission-set tool-name level): stores ~level~ for ~tool-name~
|
||||
in ~*permission-table*~. Tool names are normalized to lowercase.
|
||||
2. (permission-get tool-name): returns the stored level, or ~:ask~ if
|
||||
no entry exists.
|
||||
3. Tool name matching is case-insensitive — ~(permission-set :FOO :allow)~
|
||||
and ~(permission-get :foo)~ return ~:allow~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT enforce permissions — the Dispatcher does that.
|
||||
- Does NOT persist permissions to disk — this is runtime-only.
|
||||
- Does NOT validate that ~level~ is one of ~(:allow :ask :deny)~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Permission store (tool level)
|
||||
Hash table mapping tool names to their permission level.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
** Set permission
|
||||
Sets the permission level for a specific cognitive tool.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun permission-set (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
(setf (gethash (string-downcase (string tool-name)) *permission-table*) level))
|
||||
#+end_src
|
||||
|
||||
** Get permission
|
||||
Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun permission-get (tool-name)
|
||||
"Retrieves the permission level for a tool. Defaults to :ask."
|
||||
(gethash (string-downcase (string tool-name)) *permission-table* :ask))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-permissions
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-permissions-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:permissions-suite))
|
||||
|
||||
(in-package :passepartout-security-permissions-tests)
|
||||
|
||||
(def-suite permissions-suite :description "Verification of Tool Permissions")
|
||||
(in-suite permissions-suite)
|
||||
|
||||
(test test-permission-round-trip
|
||||
"Contract 1: permission-set stores a level; permission-get retrieves it."
|
||||
(permission-set "test-tool" :allow)
|
||||
(is (eq :allow (permission-get "test-tool")))
|
||||
;; Clean up
|
||||
(permission-set "test-tool" nil))
|
||||
|
||||
(test test-permission-default
|
||||
"Contract 2: unregistered tools default to :ask."
|
||||
(is (eq :ask (permission-get "never-registered-tool-xyz"))))
|
||||
|
||||
(test test-permission-case-insensitive
|
||||
"Contract 3: tool names are normalized to lowercase."
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
#+end_src
|
||||
92
org/security-policy.org
Normal file
92
org/security-policy.org
Normal file
@@ -0,0 +1,92 @@
|
||||
#+TITLE: SKILL: Policy (org-skill-policy.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:policy:constitutional:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/security-policy.lisp
|
||||
|
||||
* Architectural Intent: The Constitutional Layer
|
||||
|
||||
The Policy skill encodes the non-negotiable values of Passepartout. Every action the agent proposes must pass through this gate. If the action lacks justification, it is blocked — not because it's dangerous, but because it's opaque.
|
||||
|
||||
This is the "Radical Transparency" invariant in practice. The agent must explain *why* it wants to do something, not just *what* it wants to do. An action with ~:explanation "Because I said so"~ is rejected. An action with ~:explanation "The user asked me to read their TODO list and summarize it"~ passes.
|
||||
|
||||
The Policy skill is intentionally simple. It has one job: ensure every action has a meaningful explanation. Other security concerns (secret scanning, path blocking, network exfiltration) are handled by the Dispatcher. The Policy is about values, not threats.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (policy-compliance-check action context): if ~action~ has an
|
||||
~:explanation~ string longer than 10 characters, returns the action
|
||||
unchanged. Otherwise, returns a ~:LOG~ rejection plist with
|
||||
~:level :warn~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT check for dangerous content — the Dispatcher does that.
|
||||
- Does NOT validate explanation quality — only length and presence.
|
||||
- Does NOT consider ~context~ — implementation ignores it currently.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Policy Logic (policy-compliance-check)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun policy-compliance-check (action context)
|
||||
"Enforces constitutional invariants on proposed actions."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (proto-get action :payload))
|
||||
(explanation (proto-get payload :explanation)))
|
||||
(if (and explanation (stringp explanation) (> (length explanation) 10))
|
||||
action
|
||||
(progn
|
||||
(log-message "POLICY VIOLATION: Action lacks sufficient explanation.")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning."))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-policy-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:policy-suite))
|
||||
|
||||
(in-package :passepartout-security-policy-tests)
|
||||
|
||||
(def-suite policy-suite :description "Verification of the Constitutional Policy Layer")
|
||||
(in-suite policy-suite)
|
||||
|
||||
(test test-policy-passes-valid-explanation
|
||||
"Contract 1: action with sufficient explanation passes through unchanged."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today.")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (equal action result))))
|
||||
|
||||
(test test-policy-rejects-short-explanation
|
||||
"Contract 1: action with explanation ≤10 characters is rejected with :LOG."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-policy-rejects-missing-explanation
|
||||
"Contract 1: action without :explanation is rejected."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
#+end_src
|
||||
88
org/security-validator.org
Normal file
88
org/security-validator.org
Normal file
@@ -0,0 +1,88 @@
|
||||
#+TITLE: SKILL: Protocol Validator (org-skill-protocol-validator.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:protocol:validation:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/security-validator.lisp
|
||||
|
||||
* Overview
|
||||
The Protocol Validator enforces schema compliance on every message entering or leaving the cognitive pipeline. It checks that messages are valid plists, that they have the required ~:type~ and ~:payload~ fields, and that the type is one of the known types (~:REQUEST~, ~:EVENT~, ~:RESPONSE~, ~:LOG~, ~:STATUS~). This prevents malformed messages from crashing the pipeline and ensures backward compatibility when the protocol evolves.
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Protocol Validator wraps ~validate-communication-protocol-schema~
|
||||
(the core communication function) in a skill-level gate. It is the first
|
||||
filter every message passes through — malformed messages are rejected
|
||||
before they reach any cognitive stage.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (validator-protocol-check msg): returns ~msg~ if valid per
|
||||
~validate-communication-protocol-schema~. Signals ~error~ on
|
||||
malformed messages (caught by the skill's deterministic gate).
|
||||
2. The skill's deterministic gate wraps the validator: valid actions pass
|
||||
through; invalid actions produce a ~:LOG~ rejection with
|
||||
~:level :error~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT define the schema — that is ~core-transport.org~.
|
||||
- Does NOT validate semantic content — that is the Dispatcher and Policy.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-validator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:validator-suite))
|
||||
|
||||
(in-package :passepartout-security-validator-tests)
|
||||
|
||||
(def-suite validator-suite :description "Verification of the Protocol Validator")
|
||||
(in-suite validator-suite)
|
||||
|
||||
(test test-validator-passes-valid-message
|
||||
"Contract 1: a valid message passes protocol check."
|
||||
(let ((msg '(:type :EVENT :payload (:sensor :heartbeat))))
|
||||
(handler-case
|
||||
(progn
|
||||
(validator-protocol-check msg)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Validator rejected a valid message: ~a" c)))))
|
||||
|
||||
(test test-validator-rejects-missing-type
|
||||
"Contract 1: a message missing :type is rejected."
|
||||
(let ((msg '(:payload (:sensor :heartbeat))))
|
||||
(signals error
|
||||
(validator-protocol-check msg))))
|
||||
#+end_src
|
||||
159
org/security-vault.org
Normal file
159
org/security-vault.org
Normal file
@@ -0,0 +1,159 @@
|
||||
#+TITLE: SKILL: Credentials Vault (org-skill-credentials-vault.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:security:vault:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/security-vault.lisp
|
||||
|
||||
* Overview
|
||||
The *Credentials Vault* provides secure in-memory storage for sensitive API keys and session tokens.
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Credentials Vault isolates secrets from the rest of the system in
|
||||
a dedicated hash-table. It provides simple get/set primitives with
|
||||
environment-variable fallback for known providers. This is the single
|
||||
place where credentials enter the system — every provider skill routes
|
||||
through here.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (vault-set provider secret &key type): stores secret under
|
||||
~(format nil "~a-~a" provider type)~ in ~*vault-memory*~.
|
||||
2. (vault-get provider &key type): returns the stored secret, or falls
|
||||
back to the appropriate environment variable for known providers
|
||||
(~:openai~, ~:anthropic~, ~:openrouter~, ~:gemini~). Returns NIL
|
||||
if neither exists.
|
||||
3. (vault-get-secret provider): wrapper — calls ~vault-get~ with
|
||||
~:type :secret~.
|
||||
4. (vault-set-secret provider secret): wrapper — calls ~vault-set~
|
||||
with ~:type :secret~.
|
||||
5. Vault isolation: storing a secret for provider A does not affect
|
||||
provider B's entry. Different ~:type~ values produce different keys.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT encrypt at rest — that is the session layer's responsibility.
|
||||
- Does NOT validate key format — the provider skill does that.
|
||||
- Does NOT rotate or expire keys — this is a simple store.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Vault Storage
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
#+end_src
|
||||
|
||||
** Secret Management
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-get (provider &key (type :api-key))
|
||||
"Retrieves a credential from the vault or environment."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key *vault-memory*)))
|
||||
(if val
|
||||
val
|
||||
(let ((env-var (case provider
|
||||
(:gemini "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
#+end_src
|
||||
** vault-set
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-set (provider secret &key (type :api-key))
|
||||
"Stores a secret in the vault."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
#+end_src
|
||||
|
||||
** Secret Wrappers (gateway-messaging)
|
||||
|
||||
Thin wrappers that match the export names used by =gateway-messaging=.
|
||||
Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-get-secret (provider)
|
||||
"Retrieves a stored secret or token for a gateway provider."
|
||||
(vault-get provider :type :secret))
|
||||
|
||||
#+end_src
|
||||
** vault-set-secret
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-set-secret (provider secret)
|
||||
"Stores a secret or token for a gateway provider."
|
||||
(vault-set provider secret :type :secret))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-vault-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vault-suite))
|
||||
|
||||
(in-package :passepartout-security-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Verification of the Credentials Vault")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-vault-round-trip
|
||||
"Contract 1: vault-set stores a value; vault-get retrieves it."
|
||||
(let ((test-key :vault-test-round-trip)
|
||||
(test-secret "secret-abc123"))
|
||||
(vault-set test-key test-secret)
|
||||
(is (string= test-secret (vault-get test-key)))
|
||||
;; Clean up
|
||||
(vault-set test-key nil)))
|
||||
|
||||
(test test-vault-missing-key
|
||||
"Contract 2: vault-get returns NIL for an unset, unknown provider."
|
||||
(is (null (vault-get :nonexistent-provider-xyz))))
|
||||
|
||||
(test test-vault-isolation
|
||||
"Contract 5: storing for provider A does not affect provider B."
|
||||
(vault-set :vault-prov-a "secret-a")
|
||||
(vault-set :vault-prov-b "secret-b")
|
||||
(is (string= "secret-a" (vault-get :vault-prov-a)))
|
||||
(is (string= "secret-b" (vault-get :vault-prov-b)))
|
||||
(vault-set :vault-prov-a nil)
|
||||
(vault-set :vault-prov-b nil))
|
||||
|
||||
(test test-vault-secret-wrappers
|
||||
"Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret."
|
||||
(let ((test-provider :vault-secret-test))
|
||||
(vault-set-secret test-provider "my-token")
|
||||
(is (string= "my-token" (vault-get-secret test-provider)))
|
||||
;; Clean up
|
||||
(vault-set-secret test-provider nil)))
|
||||
|
||||
(test test-vault-type-isolation
|
||||
"Contract 5: different :type values produce different keys."
|
||||
(vault-set :vault-type-test "key-value" :type :api-key)
|
||||
(vault-set :vault-type-test "secret-value" :type :secret)
|
||||
(is (string= "key-value" (vault-get :vault-type-test :type :api-key)))
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
#+end_src
|
||||
217
org/sensor-time.org
Normal file
217
org/sensor-time.org
Normal file
@@ -0,0 +1,217 @@
|
||||
#+TITLE: Sensor-Time — temporal awareness skill
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:time:sensor:v0.6.0:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/sensor-time.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The heartbeat fires every 60 seconds for maintenance. It can also carry temporal
|
||||
awareness — scanning for approaching deadlines, tracking session duration, and
|
||||
injecting temporal context so the LLM knows the current time without triggering
|
||||
a call.
|
||||
|
||||
This skill provides:
|
||||
1. ~format-time-for-llm~ — injectable TIME section for system prompt
|
||||
2. ~session-duration~ — session start tracking
|
||||
3. ~sensor-time-tick~ — deadline scanning registered as cron job
|
||||
|
||||
All pure Lisp, 0 LLM tokens for temporal awareness.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (format-time-for-llm &key session-duration): returns a human-readable TIME
|
||||
section string. Respects ~TIME_AWARENESS~ and ~TIME_FORMAT~ env vars.
|
||||
2. (session-duration): returns seconds since skill load, or nil.
|
||||
3. (sensor-time-tick): scans memory for headlines with ~:DEADLINE~ or
|
||||
~:SCHEDULED~ properties. If any are within ~DEADLINE_WARNING_MINUTES~,
|
||||
returns a formatted deadline note string. Returns nil otherwise.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Session tracking
|
||||
#+begin_src lisp
|
||||
(defvar *session-start-time* nil
|
||||
"Universal time when sensor-time skill was loaded.")
|
||||
|
||||
(defun session-duration ()
|
||||
"Returns duration in seconds since skill load, or nil if not initialized."
|
||||
(when *session-start-time*
|
||||
(- (get-universal-time) *session-start-time*)))
|
||||
|
||||
(defun sensor-time-initialize ()
|
||||
"Record session start and register deadline-scanning cron."
|
||||
(setf *session-start-time* (get-universal-time))
|
||||
(handler-case
|
||||
(when (fboundp 'orchestrator-register-cron)
|
||||
(orchestrator-register-cron "time-tick"
|
||||
:action (lambda () (sensor-time-tick))
|
||||
:tier :reflex
|
||||
:repeat "+1m"))
|
||||
(error (c)
|
||||
(log-message "SENSOR-TIME: Could not register cron: ~a" c))))
|
||||
#+end_src
|
||||
|
||||
** Contract 1: format-time-for-llm
|
||||
#+begin_src lisp
|
||||
(defun format-time-for-llm (&key (session-duration-seconds nil))
|
||||
"Returns a TIME: section string for the system prompt.
|
||||
When TIME_AWARENESS=false, returns empty string.
|
||||
TIME_FORMAT: iso = 2026-05-08T06:30:00Z, natural = 6:30 AM UTC, Thu May 8 2026.
|
||||
When session-duration-seconds is provided, includes session info."
|
||||
(unless (or (uiop:getenv "TIME_AWARENESS")
|
||||
(not (string-equal "false" (or (uiop:getenv "TIME_AWARENESS") "true"))))
|
||||
(return-from format-time-for-llm ""))
|
||||
(let ((time-aware (uiop:getenv "TIME_AWARENESS")))
|
||||
(when (and time-aware (string-equal time-aware "false"))
|
||||
(return-from format-time-for-llm "")))
|
||||
(multiple-value-bind (sec minute hour date month year day daylight zone)
|
||||
(decode-universal-time (get-universal-time) 0)
|
||||
(declare (ignore daylight zone))
|
||||
(let* ((format (or (uiop:getenv "TIME_FORMAT") "iso"))
|
||||
(iso-str (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0dZ"
|
||||
year month date hour minute (round sec)))
|
||||
(day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
|
||||
(month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
|
||||
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
|
||||
(natural-str (format nil "~2,'0d:~2,'0d UTC, ~a ~a ~d ~d"
|
||||
hour minute (nth day day-names)
|
||||
(nth (1- month) month-names) date year))
|
||||
(time-str (if (string-equal format "natural") natural-str iso-str))
|
||||
(dur-str (when session-duration-seconds
|
||||
(let* ((hours (floor session-duration-seconds 3600))
|
||||
(mins (floor (mod session-duration-seconds 3600) 60)))
|
||||
(if (> hours 0)
|
||||
(format nil " Session: ~dh ~dm." hours mins)
|
||||
(format nil " Session: ~dm." mins))))))
|
||||
(if dur-str
|
||||
(format nil "TIME: ~a.~a" time-str dur-str)
|
||||
(format nil "TIME: ~a." time-str)))))
|
||||
#+end_src
|
||||
|
||||
** Contract 2: sensor-time-tick (deadline scanning)
|
||||
#+begin_src lisp
|
||||
(defvar *deadline-warning-minutes* nil)
|
||||
|
||||
(defun sensor-time-tick ()
|
||||
"Scans memory for approaching deadlines. Returns a formatted note string
|
||||
if any deadlines are within *deadline-warning-minutes*, nil otherwise.
|
||||
Called by the time-tick cron job every minute."
|
||||
(let ((warning-min (or *deadline-warning-minutes*
|
||||
(ignore-errors
|
||||
(parse-integer (uiop:getenv "DEADLINE_WARNING_MINUTES")))
|
||||
60)))
|
||||
(setf *deadline-warning-minutes* warning-min)
|
||||
(let ((now (get-universal-time))
|
||||
(deadlines nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((attrs (memory-object-attributes obj)))
|
||||
(let ((deadline (getf attrs :DEADLINE))
|
||||
(scheduled (getf attrs :SCHEDULED))
|
||||
(title (getf attrs :TITLE)))
|
||||
(dolist (prop (list deadline scheduled))
|
||||
(when prop
|
||||
(handler-case
|
||||
(let* ((parsed (parse-integer prop :junk-allowed t))
|
||||
(d-minutes (if parsed
|
||||
(- (round (/ (- parsed now) 60))
|
||||
warning-min)
|
||||
nil)))
|
||||
(when (and d-minutes (< d-minutes warning-min))
|
||||
(push (list :title title
|
||||
:minutes (- (round (/ (- (or parsed 0) now) 60))))
|
||||
deadlines)))
|
||||
(error () nil)))))))
|
||||
*memory-store*)
|
||||
(when deadlines
|
||||
(let* ((sorted (sort deadlines #'< :key (lambda (d) (getf d :minutes))))
|
||||
(parts (loop for d in sorted collect
|
||||
(let* ((mins (getf d :minutes))
|
||||
(label (cond
|
||||
((< mins 0) (format nil "~dmin overdue" (- mins)))
|
||||
((= mins 0) "now")
|
||||
(t (format nil "~dmin" mins)))))
|
||||
(format nil "~a (~a)" (getf d :title) label)))))
|
||||
(format nil "~d deadlines approaching: ~{~a; ~}" (length parts) parts))))))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
#+begin_src lisp
|
||||
(sensor-time-initialize)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-sensor-time-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:sensor-time-suite))
|
||||
|
||||
(in-package :passepartout-sensor-time-tests)
|
||||
|
||||
(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines")
|
||||
(in-suite sensor-time-suite)
|
||||
|
||||
(test test-format-time-for-llm-includes-year
|
||||
"Contract 1: format-time-for-llm returns a string with the current year."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "202" result))
|
||||
(is (search "TIME" result))))
|
||||
|
||||
(test test-format-time-for-llm-utc
|
||||
"Contract 1: iso format includes Z suffix."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "Z" result))))
|
||||
|
||||
(test test-format-time-for-llm-natural
|
||||
"Contract 1: natural format produces human-readable date."
|
||||
(let ((old-env (or (uiop:getenv "TIME_FORMAT") "")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "TIME_FORMAT") "natural")
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "UTC" result))))
|
||||
(setf (uiop:getenv "TIME_FORMAT") old-env))))
|
||||
|
||||
(test test-format-time-for-llm-with-session
|
||||
"Contract 1: with session duration, includes session info."
|
||||
(let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720)))
|
||||
(is (search "1h 2m" result))))
|
||||
|
||||
(test test-session-duration
|
||||
"Contract 2: session-duration returns a positive number after init."
|
||||
(passepartout::sensor-time-initialize)
|
||||
(let ((dur (passepartout::session-duration)))
|
||||
(is (numberp dur))
|
||||
(is (>= dur 0))))
|
||||
|
||||
(test test-sensor-time-tick-empty
|
||||
"Contract 3: sensor-time-tick returns nil when no deadlines are near."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-sensor-time-tick-detects-deadline
|
||||
"Contract 3: sensor-time-tick detects a deadline close in time."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*deadline-warning-minutes* 120)
|
||||
(let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago
|
||||
(ingest-ast (list :type :HEADLINE
|
||||
:properties (list :ID "deadline-test"
|
||||
:TITLE "Submit report"
|
||||
:DEADLINE (write-to-string near-future-time))
|
||||
:contents nil)))
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (not (null result)))
|
||||
(is (search "Submit report" result))))
|
||||
#+end_src
|
||||
@@ -3,8 +3,16 @@
|
||||
#+FILETAGS: :harness:kernel:bootstrap:
|
||||
#+STARTUP: content
|
||||
|
||||
* Overview
|
||||
The *Kernel Bootstrap* provides the absolute minimum logic required to transition from a raw POSIX shell to a functional Lisp environment.
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Kernel Bootstrap is the transition from a bare POSIX shell to a running Lisp environment. It's the only part of Passepartout that executes before the Lisp image is ready.
|
||||
|
||||
The bootstrap has exactly three jobs, nothing more:
|
||||
1. **Directory Resolution**: Locating and creating XDG paths for config, data, and state
|
||||
2. **System Tangle**: Transforming literate Org sources into runnable Lisp files
|
||||
3. **Dependency Check**: Ensuring SBCL, Quicklisp, and Emacs are available
|
||||
|
||||
This minimal interface is deliberate. The bootstrap should NOT know about LLM providers, diagnostic suites, or gateway configuration. Those are the job of the Lisp-level setup wizard, which runs after the bootstrap is complete.
|
||||
|
||||
* Phase A: Demand (Thinking)
|
||||
** The Minimalist Kernel
|
||||
@@ -20,11 +28,11 @@ To maintain sovereignty, the harness must remain a "dumb" bus. It should not kno
|
||||
|
||||
* Phase C: Implementation (Build)
|
||||
|
||||
** The Installer Script (opencortex.sh)
|
||||
** The Installer Script (passepartout)
|
||||
The shell script is the primary entry point. It handles the initial git clone, dependency installation, and literate tangle.
|
||||
|
||||
#+begin_src bash :tangle setup.sh
|
||||
#+begin_src bash :tangle no
|
||||
#!/bin/bash
|
||||
# (The content here is a duplicate of the main opencortex.sh for literate consistency)
|
||||
# (The content here is a duplicate of the main passepartout for literate consistency)
|
||||
# [Note: Implementation is already verified in the top-level script]
|
||||
#+end_src
|
||||
381
org/symbolic-archivist.org
Normal file
381
org/symbolic-archivist.org
Normal file
@@ -0,0 +1,381 @@
|
||||
#+TITLE: SKILL: Archivist (org-skill-archivist.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:archivist:scribe:gardener:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-archivist.lisp
|
||||
|
||||
* Overview
|
||||
|
||||
The *Archivist* combines the former Scribe and Gardener skills into a unified
|
||||
maintenance subsystem. It runs as a background skill triggered by heartbeat
|
||||
events, performing two core functions:
|
||||
|
||||
- Scribe: Distills daily chronological logs into structured atomic notes with
|
||||
backlinks, maintaining the Zettelkasten knowledge base.
|
||||
- Gardener: Scans the Memex for structural issues — broken =[[file:...]]= links
|
||||
and orphaned =memory-object= entries — flagging them for human review.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (archivist-extract-headlines content): parses Org content into a
|
||||
list of headline structures, each with ~:title~, ~:body~, ~:tags~.
|
||||
2. (archivist-headline-to-filename title): sanitizes a headline title
|
||||
into a valid filename — lowercased, special chars replaced.
|
||||
3. (archivist-create-note headline notes-dir source): writes a
|
||||
Zettelkasten note to disk with frontmatter and backlinks.
|
||||
4. (archivist-scribe-distill): heartbeat-driven — reads recent log
|
||||
entries from ~*history-store*~ and creates structured notes.
|
||||
5. (archivist-gardener-scan): heartbeat-driven — scans for broken
|
||||
file links and orphaned memory objects.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Archivist State
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *archivist-last-scribe* 0
|
||||
"Universal time of the last Scribe distillation run.")
|
||||
|
||||
#+end_src
|
||||
** *archivist-last-gardener*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *archivist-last-gardener* 0
|
||||
"Universal time of the last Gardener scan run.")
|
||||
|
||||
#+end_src
|
||||
** *archivist-gardener-interval*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *archivist-gardener-interval* 86400
|
||||
"Seconds between Gardener scans. Default: 24 hours.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Scribe: Knowledge Distillation
|
||||
|
||||
Reads daily log files from the Memex ~daily/= directory, extracts headlines
|
||||
and conceptual content, and creates atomic notes in ~notes/= with source
|
||||
backlinks. Tracks processed state via timestamp to avoid re-processing.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-scribe-distill ()
|
||||
"Distills daily log entries into atomic notes. Reads the Memex daily/
|
||||
directory for log files modified since the last run, extracts headlines
|
||||
as potential note seeds, and creates atomic note files in notes/ with
|
||||
backlinks to the source daily entry."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(daily-dir (merge-pathnames "daily/" memex-dir))
|
||||
(notes-dir (merge-pathnames "notes/" memex-dir))
|
||||
(now (get-universal-time))
|
||||
(notes-created 0))
|
||||
(unless (uiop:directory-exists-p daily-dir)
|
||||
(log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir)
|
||||
(return-from archivist-scribe-distill nil))
|
||||
(ensure-directories-exist notes-dir)
|
||||
(handler-case
|
||||
(let ((daily-files (uiop:directory-files daily-dir "*.org")))
|
||||
(dolist (file daily-files)
|
||||
(let* ((filepath (namestring file))
|
||||
(file-mtime (ignore-errors (file-write-date filepath))))
|
||||
(when (and file-mtime (> file-mtime *archivist-last-scribe*))
|
||||
;; Extract headlines from daily log
|
||||
(let* ((content (handler-case (uiop:read-file-string filepath)
|
||||
(error () nil)))
|
||||
(headlines (when content
|
||||
(archivist-extract-headlines content))))
|
||||
(dolist (hl headlines)
|
||||
(when (archivist-create-note hl notes-dir filepath)
|
||||
(incf notes-created))))))))
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Scribe error: ~a" c)))
|
||||
(setf *archivist-last-scribe* now)
|
||||
(when (> notes-created 0)
|
||||
(log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created))
|
||||
notes-created))
|
||||
|
||||
#+end_src
|
||||
** archivist-extract-headlines
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-extract-headlines (content)
|
||||
"Extracts first-level headlines and their content from Org text.
|
||||
Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(results nil)
|
||||
(current-title nil)
|
||||
(current-lines nil)
|
||||
(current-tags nil)
|
||||
(in-properties nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (string= trimmed ":PROPERTIES:")
|
||||
(setf in-properties t))
|
||||
(when (string= trimmed ":END:")
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
;; First-level headline
|
||||
((and (uiop:string-prefix-p "* " trimmed)
|
||||
(not (uiop:string-prefix-p "**" trimmed)))
|
||||
;; Save previous
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(setf current-title (string-trim '(#\* #\Space) trimmed)
|
||||
current-lines nil
|
||||
current-tags nil
|
||||
in-properties nil))
|
||||
;; Content lines under current headline
|
||||
(current-title
|
||||
(unless (or (uiop:string-prefix-p "*" trimmed)
|
||||
(string= trimmed ":PROPERTIES:")
|
||||
(string= trimmed ":END:"))
|
||||
(push line current-lines))))))
|
||||
;; Save last headline
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(nreverse results)))
|
||||
|
||||
#+end_src
|
||||
** archivist-headline-to-filename
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-headline-to-filename (title)
|
||||
"Converts a headline title to a valid atomic note filename.
|
||||
Replaces spaces and special chars with underscores, downcases."
|
||||
(let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title ""))
|
||||
(underscored (cl-ppcre:regex-replace-all "\\s+" clean "_"))
|
||||
(lowered (string-downcase underscored)))
|
||||
(if (> (length lowered) 100)
|
||||
(subseq lowered 0 100)
|
||||
lowered)))
|
||||
|
||||
#+end_src
|
||||
** archivist-create-note
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-create-note (headline notes-dir source-filepath)
|
||||
"Creates an atomic note from a headline plist in the notes/ directory.
|
||||
Headline is a plist (:title <str> :content <str> :tags <list>).
|
||||
Returns T if note was created, nil if it already exists."
|
||||
(let* ((title (getf headline :title))
|
||||
(content (or (getf headline :content) ""))
|
||||
(tags (getf headline :tags))
|
||||
(filename (archivist-headline-to-filename title))
|
||||
(filepath (merge-pathnames (format nil "~a.org" filename) notes-dir))
|
||||
(source-basename (enough-namestring source-filepath
|
||||
(merge-pathnames "" notes-dir))))
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(progn
|
||||
(uiop:with-output-file (s filepath :if-exists nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Gardener: Structural Maintenance
|
||||
|
||||
Scans the Memex for broken =[[file:...]]= links and orphaned =memory-object=
|
||||
entries. Flags issues with =:GARDENER:= tags for human review.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
Broken links are =[[file:...]]= references whose target file does not exist.
|
||||
Orphaned objects are =memory-object= entries whose =:parent-id= references
|
||||
a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(org-files (archivist-find-org-files memex-dir))
|
||||
(broken-links 0)
|
||||
(orphans 0))
|
||||
;; Scan for broken links
|
||||
(dolist (file org-files)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string file))
|
||||
(links (archivist-extract-file-links content)))
|
||||
(dolist (link links)
|
||||
(let ((target (merge-pathnames link (make-pathname :directory
|
||||
(pathname-directory file)))))
|
||||
(unless (uiop:file-exists-p target)
|
||||
(log-message "ARCHIVIST: Broken link in ~a -> ~a"
|
||||
(enough-namestring file memex-dir) link)
|
||||
(incf broken-links)))))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Could not read ~a" file))))
|
||||
;; Scan for orphaned memory objects
|
||||
(handler-case
|
||||
(let ((deleted-ids (make-hash-table :test 'equal)))
|
||||
;; In practice, we check if parent-id points to a non-existent object
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore obj))
|
||||
(setf (gethash id deleted-ids) t))
|
||||
(if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal)))
|
||||
(let ((store (if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal))))
|
||||
(maphash (lambda (id obj)
|
||||
(let ((parent (memory-object-parent-id obj)))
|
||||
(when (and parent (not (gethash parent store)))
|
||||
(log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)"
|
||||
id parent)
|
||||
(incf orphans))))
|
||||
store)))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Memory store not available for orphan scan")))
|
||||
(setf *archivist-last-gardener* (get-universal-time))
|
||||
(list :broken-links broken-links :orphans orphans)))
|
||||
|
||||
#+end_src
|
||||
** archivist-find-org-files
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-find-org-files (memex-dir)
|
||||
"Recursively finds all .org files under memex-dir, up to 3 levels deep."
|
||||
(let ((files nil))
|
||||
(labels ((walk (dir depth)
|
||||
(when (and (uiop:directory-exists-p dir) (< depth 3))
|
||||
(handler-case
|
||||
(dolist (entry (uiop:subdirectories dir))
|
||||
(walk entry (1+ depth)))
|
||||
(error ()))
|
||||
(handler-case
|
||||
(dolist (file (uiop:directory-files dir "*.org"))
|
||||
(push (namestring file) files))
|
||||
(error ())))))
|
||||
(walk memex-dir 0))
|
||||
files))
|
||||
|
||||
#+end_src
|
||||
** archivist-extract-file-links
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-extract-file-links (content)
|
||||
"Extracts all =[[file:...]]= link targets from Org content.
|
||||
Returns a list of link target strings."
|
||||
(let ((links nil))
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\[" content)
|
||||
(unless (search "::" target) ;; skip internal anchors
|
||||
(pushnew target links :test #'string=)))
|
||||
;; Also handle bare [[file:target]] links
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\]" content)
|
||||
(unless (search "::" target)
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Archivist Runner
|
||||
|
||||
Triggered by heartbeat events, runs Scribe and Gardener on alternating schedules.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-run (action context)
|
||||
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
||||
and dispatches as needed. Called by the deterministic gate."
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
(ignore-errors (archivist-scribe-distill)))
|
||||
;; Gardener runs every 24 hours
|
||||
(when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*)
|
||||
(ignore-errors
|
||||
(let ((result (archivist-gardener-scan)))
|
||||
(when (> (getf result :broken-links) 0)
|
||||
(log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans"
|
||||
(getf result :broken-links) (getf result :orphans)))))))
|
||||
nil)
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-archivist
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
#+end_src
|
||||
383
org/symbolic-awareness.org
Normal file
383
org/symbolic-awareness.org
Normal file
@@ -0,0 +1,383 @@
|
||||
#+TITLE: Symbolic Awareness (symbolic-awareness.lisp)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :symbolic:awareness:skill:
|
||||
#+STARTUP: content
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-awareness.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The Context API implements the Foveal-Peripheral awareness model. When the agent thinks, it doesn't dump everything it knows into the LLM's context window — that would saturate the token budget immediately. Instead, it builds a skeletal outline of the entire Memex and only shows full detail for the current focus.
|
||||
|
||||
This mirrors human attention: you are aware of your entire apartment (peripheral vision), but you only see the book in front of you in detail (foveal vision).
|
||||
|
||||
** The Foveal-Peripheral Model
|
||||
|
||||
Three factors determine how much detail an object gets:
|
||||
|
||||
1. **Depth** — objects within 2 levels of the root get full outline (title + ID). Deeper objects are summarized or omitted.
|
||||
2. **Foveal focus** — the object the user is currently interacting with gets full content rendered.
|
||||
3. **Semantic similarity** — objects whose vector embedding is similar to the current foveal focus get promoted from peripheral to foveal detail.
|
||||
|
||||
** Why Not Just Dump Everything?
|
||||
|
||||
A naive implementation that serializes every ~org-object~ to text would produce hundreds of thousands of tokens for a typical knowledge base. The LLM would spend its attention budget on noise, not signal. The Foveal-Peripheral model preserves the signal (the current task and related information) while reducing noise (everything else).
|
||||
|
||||
The semantic threshold is configurable via ~CONTEXT_SEMANTIC_THRESHOLD~ env var (default 0.75). Lower values include more peripherally related content; higher values restrict to tightly related content.
|
||||
|
||||
** Semantic Retrieval Activation (v0.4.0)
|
||||
|
||||
In v0.3.0, the infrastructure for semantic retrieval was in place — the cosine similarity calculation, the semantic threshold check, and the embedding pipeline — but ~:foveal-vector~ was never passed to ~context-object-render~. It was always ~nil~, so ~(if (and foveal-vector obj-vector ...) ...)~ always took the ~0.0~ branch. Every peripheral node had similarity zero regardless of content overlap.
|
||||
|
||||
The fix is a one-line wiring: ~context-awareness-assemble~ now extracts the foveal node's embedding vector via ~(memory-object-vector (memory-object-get foveal-id))~ and passes it as the ~:foveal-vector~ keyword argument to ~context-object-render~. This activates the entire semantic retrieval path — nodes with high cosine similarity to the foveal node are promoted to full-content rendering.
|
||||
|
||||
The effectiveness of this depends on the embedding backend. The default ~:trigram~ backend (v0.4.0 replacement for ~:hashing~/SHA-256) captures lexical overlap: if two nodes share enough character trigrams, their cosine similarity exceeds the threshold and the peripheral node is promoted to foveal detail. This gives the context model genuine semantic boosting with zero LLM tokens and zero external dependencies.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (context-awareness-assemble &optional signal): produces a skeletal
|
||||
outline of current Memory for the LLM. If ~:foveal-focus~ is set,
|
||||
the foveal node gets inline rendering; peripheral nodes get title-only.
|
||||
Privacy-filtered objects are excluded.
|
||||
2. (context-assemble-global-awareness): zero-arg wrapper — calls
|
||||
~context-awareness-assemble~ without foveal focus.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Memory Query (context-query)
|
||||
|
||||
Filters the Memory store by tag, TODO state, or object type. This is the primary retrieval function used by skills to find relevant information.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-query (&key tag todo-state type scope)
|
||||
"Filters the Memory based on tags, todo states, or types.
|
||||
Optional SCOPE restricts results to objects with that scope
|
||||
or :memex (global scope always visible)."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (memory-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
;; Scope filter: if scope specified, only match :memex (global) or same scope
|
||||
(when (and scope (not (eq (memory-object-scope obj) :memex))
|
||||
(not (eq (memory-object-scope obj) scope)))
|
||||
(setf match nil))
|
||||
(when (and type (not (eq (memory-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory-store*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
** Active Projects (context-active-projects)
|
||||
|
||||
Returns headlines tagged as ~project~ that are not yet DONE. Used by the global awareness function to build the task overview.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query :tag "project" :type :HEADLINE)))
|
||||
#+end_src
|
||||
|
||||
** Completed Tasks (context-recent-tasks)
|
||||
|
||||
Retrieves recently finished tasks from the store. Used by the Scribe and Gardener for journal summarization.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-recent-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query :todo-state "DONE" :type :HEADLINE))
|
||||
#+end_src
|
||||
|
||||
** Capability Discovery (context-skill-list)
|
||||
|
||||
Provides a sorted overview of currently loaded system capabilities. Each entry includes the skill name, priority, and dependencies.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-list ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skill-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Source Inspection (context-skill-source)
|
||||
|
||||
Reads the raw literate source of a specific skill for inspection. Used when the agent needs to understand or modify its own code.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(org-dir (merge-pathnames "org/" data-dir))
|
||||
(full-path (merge-pathnames filename org-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
#+end_src
|
||||
|
||||
** Subtree Skill Source (context-skill-subtree)
|
||||
|
||||
Returns a specific headline subtree from a skill's Org file. Delegates to
|
||||
=org-subtree-extract= in the =programming-org= skill for actual parsing.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-subtree (skill-name heading-name)
|
||||
"Reads a specific headline subtree from a skill's Org source file.
|
||||
Returns the content under HEADING-NAME (including children) as a string,
|
||||
or nil if the heading is not found."
|
||||
(let ((full-source (context-skill-source skill-name)))
|
||||
(unless full-source (return-from context-skill-subtree nil))
|
||||
(if (fboundp 'org-subtree-extract)
|
||||
(org-subtree-extract full-source heading-name)
|
||||
;; Fallback: no org-subtree-extract available, return full source
|
||||
full-source)))
|
||||
#+end_src
|
||||
|
||||
** Harness Logs (context-logs)
|
||||
|
||||
Retrieves the most recent lines from the harness's internal log buffer. The log limit is configurable via ~CONTEXT_LOG_LIMIT~ env var (default 20).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*log-lock*)
|
||||
(let ((count (min log-limit (length *log-buffer*))))
|
||||
(subseq *log-buffer* 0 count)))))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias (context-get-system-logs)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Backward-compatibility alias for context-logs."
|
||||
(context-logs limit))
|
||||
#+end_src
|
||||
|
||||
** AST to Org Rendering (context-object-render)
|
||||
|
||||
Recursively renders an ~org-object~ and its children to an Org-mode string, applying the Foveal-Peripheral model:
|
||||
|
||||
- Objects within depth 2 are always included (outline)
|
||||
- The foveal object (the one the user is looking at) is always included with full content
|
||||
- Objects with semantic similarity above the threshold are included with full content
|
||||
- All other objects are omitted silently
|
||||
|
||||
This function is the heart of the context assembly. Its performance directly affects the agent's response time.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (memory-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (memory-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (memory-object-content obj))
|
||||
(children (memory-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (memory-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(vector-cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when is-semantically-relevant
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (memory-object-get child-id)))
|
||||
(when child-obj
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-object-render child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Path Resolution (context-path-resolve)
|
||||
|
||||
Expands environment variables in a path string and strips quotes. Used to resolve configurable paths from ~.env~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-path-resolve (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
path-string)))
|
||||
(if (and (stringp path) (search "$" path))
|
||||
(let ((result path))
|
||||
(ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path)
|
||||
(let ((var-val (uiop:getenv var-name)))
|
||||
(when var-val
|
||||
(setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val)))))
|
||||
result)
|
||||
path)))
|
||||
#+end_src
|
||||
|
||||
** Privacy Filter for Context Assembly
|
||||
|
||||
Checks if an org-object has tags matching the Dispatcher's privacy tags. Objects with matching tags are excluded from the LLM's context window. This prevents private content tagged with ~@personal~ (or any user-configured privacy tag) from being included in prompts sent to external LLM providers.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches the Dispatcher's privacy tags."
|
||||
(let* ((attrs (memory-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :passepartout.security-dispatcher)
|
||||
(symbol-value
|
||||
(find-symbol "*DISPATCHER-PRIVACY-TAGS*"
|
||||
:passepartout.security-dispatcher)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
#+end_src
|
||||
|
||||
** Global Awareness (context-awareness-assemble)
|
||||
|
||||
Produces the high-level skeletal outline of the current Memory that is included in every LLM call. This is the "peripheral vision" of the agent — it knows what projects exist, their titles and IDs, but not their full content.
|
||||
|
||||
Privacy-filtered projects (those with tags matching the Dispatcher's privacy tags) are excluded from the output.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-awareness-assemble (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM.
|
||||
Privacy-filtered objects (matching the Dispatcher's privacy tags) are excluded."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(foveal-vector (when foveal-id
|
||||
(memory-object-vector (memory-object-get foveal-id))))
|
||||
(all-projects (context-active-projects))
|
||||
(projects (remove-if #'context-privacy-filtered-p all-projects))
|
||||
(output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%")))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-object-render project :foveal-id foveal-id :foveal-vector foveal-vector))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias
|
||||
|
||||
The global awareness function was renamed from ~context-assemble-global-awareness~
|
||||
to ~context-awareness-assemble~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-assemble-global-awareness ()
|
||||
(context-awareness-assemble))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-awareness
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Foveal-Peripheral rendering correctly distinguishes between foveal (detailed) and peripheral (outline) content, and that the awareness budget includes all active projects.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
(test test-semantic-retrieval-trigram
|
||||
"Contract v0.4.0: trigram backend produces non-zero similarity for related content."
|
||||
(let ((v1 (passepartout::embedding-backend-trigram "implement user login form"))
|
||||
(v2 (passepartout::embedding-backend-trigram "add password authentication")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.0))))
|
||||
(let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module"))
|
||||
(v4 (passepartout::embedding-backend-trigram "authentication login form handler fix")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v3 v4)))
|
||||
(is (> sim 0.75))))
|
||||
(let ((v5 (passepartout::embedding-backend-trigram "authentication"))
|
||||
(v6 (passepartout::embedding-backend-trigram "banana")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
|
||||
(is (< sim 0.3)))))
|
||||
#+end_src
|
||||
@@ -1,43 +1,47 @@
|
||||
#+TITLE: SKILL: Config Manager (org-skill-config-manager.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:setup:config:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-config-manager.lisp
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-config.lisp
|
||||
|
||||
* Overview
|
||||
The *Config Manager* skill provides the OpenCortex Agent with the capability to manage its own environment variables and provider configurations. It includes an interactive setup wizard for LLM providers, gateways, and system settings.
|
||||
The *Config Manager* skill provides the Passepartout Agent with the capability to manage its own environment variables and provider configurations. It includes an interactive setup wizard for LLM providers, gateways, and system settings.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Configuration directory (get-oc-config-dir)
|
||||
Resolves the XDG config directory for OpenCortex.
|
||||
** Configuration directory (config-directory)
|
||||
Resolves the XDG config directory for Passepartout.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun get-oc-config-dir ()
|
||||
(defun config-directory ()
|
||||
"Returns the absolute path to the opencortex config directory."
|
||||
(let ((xdg (uiop:getenv "OC_CONFIG_DIR")))
|
||||
(if xdg xdg (namestring (merge-pathnames ".config/opencortex/" (user-homedir-pathname))))))
|
||||
(if xdg xdg (namestring (merge-pathnames ".config/passepartout/" (user-homedir-pathname))))))
|
||||
#+end_src
|
||||
|
||||
** Config file path (get-config-file)
|
||||
** Config file path (config-file-path)
|
||||
Returns the path to the ~.env~ file within the config directory.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun get-config-file ()
|
||||
(defun config-file-path ()
|
||||
"Returns the path to the .env configuration file."
|
||||
(merge-pathnames ".env" (get-oc-config-dir)))
|
||||
(merge-pathnames ".env" (config-directory)))
|
||||
#+end_src
|
||||
|
||||
** Ensure config directory (ensure-config-dir)
|
||||
** Ensure config directory (config-directory-ensure)
|
||||
Creates the config directory tree if it does not exist.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun ensure-config-dir ()
|
||||
(defun config-directory-ensure ()
|
||||
"Creates the configuration directory if it does not exist."
|
||||
(ensure-directories-exist (get-oc-config-dir)))
|
||||
(ensure-directories-exist (config-directory)))
|
||||
#+end_src
|
||||
|
||||
** Config File Operations
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun read-config-file ()
|
||||
(defun config-read ()
|
||||
"Reads the .env config file and returns an alist of KEY=VALUE pairs."
|
||||
(let ((config-file (get-config-file)))
|
||||
(let ((config-file (config-file-path)))
|
||||
(when (uiop:file-exists-p config-file)
|
||||
(let ((lines (uiop:read-file-lines config-file))
|
||||
(result nil))
|
||||
@@ -51,40 +55,59 @@ Creates the config directory tree if it does not exist.
|
||||
(push (cons key value) result))))))
|
||||
(nreverse result)))))
|
||||
|
||||
(defun write-config-file (config-alist)
|
||||
#+end_src
|
||||
** config-write
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-write (config-alist)
|
||||
"Writes the config alist to the .env file."
|
||||
(ensure-config-dir)
|
||||
(let ((config-file (get-config-file)))
|
||||
(config-directory-ensure)
|
||||
(let ((config-file (config-file-path)))
|
||||
(with-open-file (stream config-file :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(format stream "# OpenCortex Configuration~%")
|
||||
(format stream "# Passepartout Configuration~%")
|
||||
(format stream "# Generated by opencortex setup~%~%")
|
||||
(dolist (pair config-alist)
|
||||
(format stream "~a=~a~%" (car pair) (cdr pair))))))
|
||||
|
||||
(defun get-config-value (key)
|
||||
#+end_src
|
||||
** config-get
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-get (key)
|
||||
"Gets a config value by key."
|
||||
(let ((config (read-config-file)))
|
||||
(let ((config (config-read)))
|
||||
(cdr (assoc key config :test #'string=))))
|
||||
|
||||
(defun set-config-value (key value)
|
||||
#+end_src
|
||||
** config-set
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-set (key value)
|
||||
"Sets a config value and saves to file."
|
||||
(let ((config (read-config-file))
|
||||
(let ((config (config-read))
|
||||
(pair (cons key value)))
|
||||
(let ((existing (assoc key config :test #'string=)))
|
||||
(if existing
|
||||
(setf (cdr existing) value)
|
||||
(push pair config))
|
||||
(write-config-file config))))
|
||||
(config-write config))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Input Utilities
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt (prompt-text)
|
||||
"Simple prompt that returns user input as a string."
|
||||
"Simple prompt that returns user input as a string.
|
||||
Returns nil if stdin is non-interactive."
|
||||
(format t "~a" prompt-text)
|
||||
(finish-output)
|
||||
(read-line))
|
||||
(ignore-errors (read-line)))
|
||||
|
||||
#+end_src
|
||||
** prompt-yes-no
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt-yes-no (prompt-text)
|
||||
"Prompts yes/no question. Returns T for yes, nil for no."
|
||||
(let ((response (prompt (format nil "~a [Y/n]: " prompt-text))))
|
||||
@@ -93,6 +116,10 @@ Creates the config directory tree if it does not exist.
|
||||
(string-equal response "y")
|
||||
(string-equal response "yes"))))
|
||||
|
||||
#+end_src
|
||||
** prompt-choice
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt-choice (prompt-text options)
|
||||
"Prompts user to choose from a list of options. Returns the chosen option or nil."
|
||||
(format t "~a~%" prompt-text)
|
||||
@@ -105,8 +132,10 @@ Creates the config directory tree if it does not exist.
|
||||
(when (and num (<= 1 num) (>= (length options) num))
|
||||
(nth (1- num) options)))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** LLM Provider Setup
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defparameter *available-providers*
|
||||
'(("OpenAI" . "OPENAI_API_KEY")
|
||||
@@ -114,8 +143,29 @@ Creates the config directory tree if it does not exist.
|
||||
("OpenRouter" . "OPENROUTER_API_KEY")
|
||||
("Groq" . "GROQ_API_KEY")
|
||||
("Gemini" . "GEMINI_API_KEY")
|
||||
("Ollama (local)" . "OLLAMA_URL")))
|
||||
("DeepSeek" . "DEEPSEEK_API_KEY")
|
||||
("NVIDIA" . "NVIDIA_API_KEY")
|
||||
("Local" . "LOCAL_BASE_URL")))
|
||||
|
||||
#+end_src
|
||||
** Provider descriptions (for setup wizard display)
|
||||
|
||||
These are shown inline when the user runs the setup wizard, so they know what they are choosing.
|
||||
|
||||
| Provider | Description | Where to sign up | Recommendation |
|
||||
|----------|-------------|------------------|--------------|
|
||||
| ~OpenRouter~ | Free tier with 33+ models. No credit card required. Routes to best available free model. | openrouter.ai | ★ Recommended for new users |
|
||||
| ~OpenAI~ | GPT-4o-mini and GPT-4o. Requires billing. | platform.openai.com | |
|
||||
| ~Anthropic~ | Claude 3.5 Sonnet. Strong reasoning. | console.anthropic.com | |
|
||||
| ~Groq~ | Very fast inference, free tier available. | console.groq.com | |
|
||||
| ~Gemini~ | Google's Gemini models. Free tier via API. | aistudio.google.com | |
|
||||
| ~DeepSeek~ | Competitive pricing, strong coding. | platform.deepseek.com | |
|
||||
| ~NVIDIA~ | NVIDIA NIM. Hosted models, slower but capable. | build.nvidia.com | |
|
||||
| ~Local~ | Any OpenAI-compatible local server (llama.cpp, vLLM, LM Studio, Ollama). No API key needed. | Run locally | |
|
||||
|
||||
** setup-llm-providers
|
||||
;; REPL-VERIFIED: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
(format t "~%~%")
|
||||
@@ -124,40 +174,77 @@ Creates the config directory tree if it does not exist.
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((current-providers (loop for (name . key) in *available-providers*
|
||||
when (get-config-value key)
|
||||
when (config-get key)
|
||||
collect name)))
|
||||
(when current-providers
|
||||
(format t "Current providers: ~{~a~^, ~}~%~%" current-providers))
|
||||
(format t "Currently configured: ~{~a~^, ~}~%~%" current-providers))
|
||||
|
||||
(format t "~%")
|
||||
(format t "★ OpenRouter recommended for new users — free tier, no credit card required.~%")
|
||||
(format t " Sign up at https://openrouter.ai and paste your API key below.~%")
|
||||
(format t "~%")
|
||||
(format t "Available providers:~%")
|
||||
(format t " ~20@A ~25@A ~s~%" "Provider" "Key env var" "Notes")
|
||||
(format t " ~20@A ~25@A ~s~%" "--------" "----------" "-----")
|
||||
(dolist (p *available-providers*)
|
||||
(format t " - ~a~%" (car p)))
|
||||
(let ((name (car p))
|
||||
(env-key (cdr p))
|
||||
(desc (case (car p)
|
||||
("OpenRouter" "free tier, 33+ models")
|
||||
("OpenAI" "paid, gpt-4o-mini")
|
||||
("Anthropic" "paid, Claude 3.5 Sonnet")
|
||||
("Groq" "fast inference, free tier")
|
||||
("Gemini" "free via API")
|
||||
("DeepSeek" "competitive pricing, coding")
|
||||
("NVIDIA" "NVIDIA NIM hosted models")
|
||||
("Local" "local server, no API key")
|
||||
(t ""))))
|
||||
(format t " ~20@A ~25@A ~a~%" name env-key desc)))
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a new provider?")
|
||||
(let ((chosen (prompt-choice "Select provider:" (mapcar #'car *available-providers*))))
|
||||
(when chosen
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(if (string= chosen "Ollama (local)")
|
||||
(progn
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(set-config-value env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(set-config-value env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
(loop
|
||||
(when (not (prompt-yes-no "Configure a LLM provider?"))
|
||||
(return))
|
||||
(let ((chosen (prompt-choice "Select a provider:" (mapcar #'car *available-providers*))))
|
||||
(unless chosen
|
||||
(format t "Invalid choice.~%")
|
||||
(return))
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(cond
|
||||
((string= chosen "Local")
|
||||
(format t "Enter the server URL (e.g., http://localhost:11434 for Ollama,~%")
|
||||
(format t " or http://localhost:8080 for llama.cpp): ")
|
||||
(let ((url (read-line)))
|
||||
(if (> (length url) 0)
|
||||
(progn (config-set env-key url)
|
||||
(format t "✓ ~a configured at ~a~%" chosen url))
|
||||
(format t "Skipping ~a — no URL entered.~%" chosen))))
|
||||
(t
|
||||
(format t "Enter API key for ~a~%" chosen)
|
||||
(format t " (get one from the provider's website, paste it here): ")
|
||||
(let ((key (read-line)))
|
||||
(if (> (length key) 0)
|
||||
(progn (config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen))
|
||||
(format t "Skipping ~a — no key entered.~%" chosen))))))))
|
||||
|
||||
(format t "~%")))
|
||||
|
||||
|
||||
|
||||
|
||||
#+end_src
|
||||
** setup-add-provider
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
(setup-llm-providers))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Gateway Setup
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-gateways ()
|
||||
"Interactive wizard for configuring external gateways."
|
||||
@@ -176,14 +263,15 @@ Creates the config directory tree if it does not exist.
|
||||
(when chosen
|
||||
(let ((token (prompt (format nil "Enter ~a bot token: " chosen))))
|
||||
(if (string= chosen "Slack")
|
||||
(set-config-value "SLACK_TOKEN" token)
|
||||
(set-config-value "DISCORD_TOKEN" token))
|
||||
(config-set "SLACK_TOKEN" token)
|
||||
(config-set "DISCORD_TOKEN" token))
|
||||
(format t "✓ ~a gateway configured~%" chosen)))))
|
||||
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
** Skill Management
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-skills ()
|
||||
"Interactive wizard for enabling/disabling skills."
|
||||
@@ -193,11 +281,12 @@ Creates the config directory tree if it does not exist.
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(format t "Note: Skill management is not yet implemented.~%")
|
||||
(format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "OC_DATA_DIR") "~/.local/share/opencortex"))
|
||||
(format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") "~/.local/share/passepartout"))
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
** Memory Settings
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-memory ()
|
||||
"Interactive wizard for memory settings."
|
||||
@@ -208,17 +297,18 @@ Creates the config directory tree if it does not exist.
|
||||
|
||||
(let ((auto-save (prompt "Auto-save interval in seconds [300]:")))
|
||||
(when (and auto-save (> (length auto-save) 0))
|
||||
(set-config-value "MEMORY_AUTO_SAVE_INTERVAL" auto-save)))
|
||||
(config-set "MEMORY_AUTO_SAVE_INTERVAL" auto-save)))
|
||||
|
||||
(let ((history (prompt "History retention in lines [1000]:")))
|
||||
(when (and history (> (length history) 0))
|
||||
(set-config-value "MEMORY_HISTORY_RETENTION" history)))
|
||||
(config-set "MEMORY_HISTORY_RETENTION" history)))
|
||||
|
||||
(format t "✓ Memory settings saved~%")
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
** Network Settings
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-network ()
|
||||
"Interactive wizard for network settings."
|
||||
@@ -229,23 +319,24 @@ Creates the config directory tree if it does not exist.
|
||||
|
||||
(let ((timeout (prompt "Request timeout in seconds [30]:")))
|
||||
(when (and timeout (> (length timeout) 0))
|
||||
(set-config-value "REQUEST_TIMEOUT" timeout)))
|
||||
(config-set "REQUEST_TIMEOUT" timeout)))
|
||||
|
||||
(let ((proxy (prompt "Proxy URL (leave empty for none) []:")))
|
||||
(when (and proxy (> (length proxy) 0))
|
||||
(set-config-value "HTTP_PROXY" proxy)))
|
||||
(config-set "HTTP_PROXY" proxy)))
|
||||
|
||||
(format t "✓ Network settings saved~%")
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
** Main Setup Wizard
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun run-setup-wizard ()
|
||||
(defun setup-wizard-run ()
|
||||
"Main entry point for the interactive setup wizard."
|
||||
(format t "~%~%")
|
||||
(format t "╔═══════════════════════════════════════════════════╗~%")
|
||||
(format t "║ OpenCortex Setup Wizard ║~%")
|
||||
(format t "║ Passepartout Setup Wizard ║~%")
|
||||
(format t "╚═══════════════════════════════════════════════════╝~%")
|
||||
(format t "~%")
|
||||
(format t "This wizard will help you configure:~%")
|
||||
@@ -255,7 +346,7 @@ Creates the config directory tree if it does not exist.
|
||||
(format t " 4. Network Settings~%")
|
||||
(format t "~%")
|
||||
|
||||
(ensure-config-dir)
|
||||
(config-directory-ensure)
|
||||
|
||||
;; Step 1: LLM Providers
|
||||
(when (prompt-yes-no "Configure LLM providers?")
|
||||
@@ -278,15 +369,15 @@ Creates the config directory tree if it does not exist.
|
||||
(format t " Setup Complete!~%")
|
||||
(format t "==================================================~%")
|
||||
(format t "~%")
|
||||
(format t "Configuration saved to: ~a~%" (get-config-file))
|
||||
(format t "Configuration saved to: ~a~%" (config-file-path))
|
||||
(format t "~%")
|
||||
(format t "To verify your setup, run: opencortex doctor~%")
|
||||
(format t "To verify your setup, run: passepartout doctor~%")
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-config-manager
|
||||
(defskill :passepartout-symbolic-config
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
@@ -1,10 +1,11 @@
|
||||
#+TITLE: SKILL: Diagnostics (org-skill-diagnostics.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:diagnostics:doctor:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-diagnostics.lisp
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-diagnostics.lisp
|
||||
|
||||
* Overview
|
||||
The *Diagnostics Skill* (Doctor) provides system-wide health checks and dependency verification. It validates external dependencies, XDG environment, and LLM provider connectivity.
|
||||
* Why a Doctor?
|
||||
|
||||
The Diagnostics skill is the self-knowledge of Passepartout. It answers "Is everything working?" by checking dependencies, environment variables, and LLM connectivity. Unlike the harness-level Doctor (which runs at boot and on CLI demand), this skill provides the Lisp-level diagnostic functions — defining what "healthy" means: which binaries must be present, which directories must exist, which API keys should be configured.
|
||||
|
||||
* Phase A: Demand (Thinking)
|
||||
** Why a Doctor?
|
||||
@@ -13,43 +14,66 @@ The Doctor transforms opaque startup failures into actionable engineering report
|
||||
** Detection Invariant
|
||||
Binary detection must use shell probing (`which`) to account for varying `$PATH` inheritance between interactive and headless sessions.
|
||||
|
||||
* Phase B: Protocol (Success Criteria)
|
||||
- Dependency check passes when all required binaries are found
|
||||
- Environment check passes when XDG directories exist and are accessible
|
||||
- LLM check passes when at least one provider is configured or Ollama is running locally
|
||||
* Phase B: Contract
|
||||
|
||||
1. (diagnostics-dependencies-check): probes PATH for every binary in
|
||||
~*diagnostics-binaries*~. Returns T if all found, NIL if any missing.
|
||||
Side-effect: populates ~*doctor-missing-deps*~.
|
||||
2. (diagnostics-env-check): validates XDG directories exist. Returns T
|
||||
if all critical dirs present, NIL otherwise.
|
||||
3. (diagnostics-run-all &key auto-install): orchestrates 1-3. Returns
|
||||
a plist with ~:deps~, ~:env~, ~:llm~ keys. Respects ~:auto-install nil~.
|
||||
|
||||
* Phase C: Implementation (Build)
|
||||
|
||||
** Global Configuration
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Global Configuration
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *diagnostics-binaries* '("sbcl" "emacs" "git")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
(defvar *doctor-package-map*
|
||||
#+end_src
|
||||
** *diagnostics-package-map*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *diagnostics-package-map*
|
||||
'(("sbcl" . "sbcl")
|
||||
("emacs" . "emacs")
|
||||
("git" . "git")
|
||||
("socat" . "socat")
|
||||
("nc" . "netcat-openbsd")
|
||||
("curl" . "curl")
|
||||
("rlwrap" . "rlwrap"))
|
||||
"Map binary names to apt package names.")
|
||||
|
||||
#+end_src
|
||||
** *doctor-missing-deps*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-missing-deps* nil
|
||||
"List of missing dependencies populated by doctor-check-dependencies.")
|
||||
"List of missing dependencies populated by diagnostics-dependencies-check.")
|
||||
|
||||
#+end_src
|
||||
** *doctor-auto-install*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-auto-install* t
|
||||
"When T, doctor will attempt to install missing dependencies automatically.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Dependency Verification
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-dependencies ()
|
||||
(defun diagnostics-dependencies-check ()
|
||||
"Verifies that required external binaries are available in the PATH via shell probe."
|
||||
(setf *doctor-missing-deps* nil)
|
||||
(let ((all-ok t))
|
||||
(format t "DOCTOR: Checking system dependencies...~%")
|
||||
(dolist (dep *doctor-required-binaries*)
|
||||
(dolist (dep *diagnostics-binaries*)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
:output :string :ignore-error-status t))))
|
||||
@@ -65,18 +89,19 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
#+end_src
|
||||
|
||||
** Auto-Install Dependencies
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-install-dependencies ()
|
||||
(defun diagnostics-dependencies-install ()
|
||||
"Attempts to install missing system dependencies via apt."
|
||||
(when (null *doctor-missing-deps*)
|
||||
(format t "DOCTOR: No missing dependencies to install.~%")
|
||||
(return-from doctor-install-dependencies t))
|
||||
(return-from diagnostics-dependencies-install t))
|
||||
|
||||
(format t "DOCTOR: Attempting to install ~a missing dependencies...~%" (length *doctor-missing-deps*))
|
||||
|
||||
(let ((packages (remove-duplicates
|
||||
(mapcar (lambda (dep)
|
||||
(or (cdr (assoc dep *doctor-package-map* :test #'string=))
|
||||
(or (cdr (assoc dep *diagnostics-package-map* :test #'string=))
|
||||
dep))
|
||||
*doctor-missing-deps*)
|
||||
:test #'string=)))
|
||||
@@ -104,14 +129,15 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
#+end_src
|
||||
|
||||
** XDG Environment Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-env ()
|
||||
(defun diagnostics-env-check ()
|
||||
"Validates XDG directories and environment configuration."
|
||||
(format t "DOCTOR: Checking XDG environment...~%")
|
||||
(let ((all-ok t)
|
||||
(config-dir (uiop:getenv "OC_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "OC_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "OC_STATE_DIR"))
|
||||
(config-dir (uiop:getenv "PASSEPARTOUT_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "PASSEPARTOUT_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "PASSEPARTOUT_STATE_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR")))
|
||||
|
||||
(flet ((check-dir (name path critical)
|
||||
@@ -125,9 +151,9 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
(format t " [FAIL] ~a variable not set.~%" name)
|
||||
(when critical (setf all-ok nil))))))
|
||||
|
||||
(check-dir "Config (OC_CONFIG_DIR)" config-dir t)
|
||||
(check-dir "Data (OC_DATA_DIR)" data-dir t)
|
||||
(check-dir "State (OC_STATE_DIR)" state-dir t)
|
||||
(check-dir "Config (PASSEPARTOUT_CONFIG_DIR)" config-dir t)
|
||||
(check-dir "Data (PASSEPARTOUT_DATA_DIR)" data-dir t)
|
||||
(check-dir "State (PASSEPARTOUT_STATE_DIR)" state-dir t)
|
||||
(check-dir "Memex (MEMEX_DIR)" memex-dir t))
|
||||
all-ok))
|
||||
#+end_src
|
||||
@@ -135,16 +161,19 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
** LLM Connectivity
|
||||
The doctor checks all supported LLM providers and detects local Ollama instances.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-check-llm ()
|
||||
(defun diagnostics-llm-check ()
|
||||
"Tests connectivity to LLM providers. Returns T if at least one provider is configured."
|
||||
(format t "DOCTOR: Checking LLM connectivity...~%")
|
||||
(let ((providers '((:openrouter . "OPENROUTER_API_KEY")
|
||||
(:anthropic . "ANTHROPIC_API_KEY")
|
||||
(:openai . "OPENAI_API_KEY")
|
||||
(:groq . "GROQ_API_KEY")
|
||||
(:gemini . "GEMINI_API_KEY")
|
||||
(:ollama . "OLLAMA_URL")))
|
||||
(:anthropic . "ANTHROPIC_API_KEY")
|
||||
(:openai . "OPENAI_API_KEY")
|
||||
(:groq . "GROQ_API_KEY")
|
||||
(:gemini . "GEMINI_API_KEY")
|
||||
(:deepseek . "DEEPSEEK_API_KEY")
|
||||
(:nvidia . "NVIDIA_API_KEY")
|
||||
(:ollama . "OLLAMA_URL")))
|
||||
(configured nil))
|
||||
(dolist (p providers)
|
||||
(let ((env-val (uiop:getenv (cdr p))))
|
||||
@@ -165,25 +194,26 @@ The doctor checks all supported LLM providers and detects local Ollama instances
|
||||
t)
|
||||
(progn
|
||||
(format t " [WARN] No LLM provider configured.~%")
|
||||
(format t " Run 'opencortex setup' to configure a provider.~%")
|
||||
(format t " Run 'passepartout configure' to configure a provider.~%")
|
||||
t))))
|
||||
#+end_src
|
||||
|
||||
** Orchestration
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-run-all (&key (auto-install t))
|
||||
(defun diagnostics-run-all (&key (auto-install t))
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
(format t "==================================================~%")
|
||||
(format t " OPENCORTEX DOCTOR: Commencing Health Check~%")
|
||||
(format t " PASSEPARTOUT DOCTOR: Commencing Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(let ((dep-ok (doctor-check-dependencies)))
|
||||
(let ((dep-ok (diagnostics-dependencies-check)))
|
||||
(when (and (not dep-ok) auto-install *doctor-auto-install*)
|
||||
(format t "DOCTOR: Attempting automatic installation...~%")
|
||||
(setf dep-ok (doctor-install-dependencies))
|
||||
(setf dep-ok (diagnostics-dependencies-install))
|
||||
(when dep-ok
|
||||
(setf dep-ok (doctor-check-dependencies))))
|
||||
(let ((env-ok (doctor-check-env))
|
||||
(llm-ok (doctor-check-llm)))
|
||||
(setf dep-ok (diagnostics-dependencies-check))))
|
||||
(let ((env-ok (diagnostics-env-check))
|
||||
(llm-ok (diagnostics-llm-check)))
|
||||
(format t "==================================================~%")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
@@ -198,41 +228,58 @@ The doctor checks all supported LLM providers and detects local Ollama instances
|
||||
(format t " - No LLM provider configured~%"))
|
||||
(format t "~%")
|
||||
(format t " RECOMMENDED ACTIONS:~%")
|
||||
(format t " 1. Run 'opencortex setup' to configure everything~%")
|
||||
(format t " 2. Or run 'opencortex doctor --fix' for auto-repair~%")
|
||||
(format t " 1. Run 'passepartout configure' to configure everything~%")
|
||||
(format t " 2. Or run 'passepartout doctor --fix' for auto-repair~%")
|
||||
(format t "==================================================~%")
|
||||
nil))))) ;; Return nil when issues found
|
||||
#+end_src
|
||||
|
||||
** CLI Entry Point
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun doctor-main ()
|
||||
(defun diagnostics-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
(if (doctor-run-all)
|
||||
(if (diagnostics-run-all)
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
#+end_src
|
||||
|
||||
* Phase D: Verification (Testing)
|
||||
|
||||
** Dependency Test
|
||||
#+begin_src lisp :tangle no
|
||||
(test test-doctor-dependency-check
|
||||
"Verify that missing binaries are correctly identified as failures."
|
||||
(let ((opencortex::*doctor-required-binaries* '("non-existent-binary-123")))
|
||||
(is (null (opencortex:doctor-check-dependencies)))))
|
||||
#+end_src
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
** Environment Test
|
||||
#+begin_src lisp :tangle no
|
||||
(test test-doctor-env-check
|
||||
"Verify that an invalid MEMEX_DIR triggers a critical failure."
|
||||
(let ((old-m (uiop:getenv "MEMEX_DIR")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "MEMEX_DIR") "/non/existent/path/999")
|
||||
(is (null (opencortex:doctor-check-env))))
|
||||
(setf (uiop:getenv "MEMEX_DIR") (or old-m "")))))
|
||||
(defpackage :passepartout-diagnostics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:diagnostics-suite))
|
||||
|
||||
(in-package :passepartout-diagnostics-tests)
|
||||
|
||||
(def-suite diagnostics-suite :description "Verification of the System Diagnostics logic")
|
||||
(in-suite diagnostics-suite)
|
||||
|
||||
(test test-diagnostics-dependency-fail
|
||||
"Contract 1: missing binaries cause diagnostics-dependencies-check to return nil."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("non-existent-binary-123"))
|
||||
(is (null (diagnostics-dependencies-check))))))
|
||||
|
||||
(test test-diagnostics-env-fail
|
||||
"Contract 2: diagnostics-env-check returns a boolean."
|
||||
(let ((result (diagnostics-env-check)))
|
||||
(is (or (eq t result) (eq nil result))
|
||||
"diagnostics-env-check should return T or NIL")))
|
||||
|
||||
(test test-diagnostics-dependency-success
|
||||
"Contract 1: all binaries present returns T."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("ls"))
|
||||
(is (eq t (diagnostics-dependencies-check))))))
|
||||
#+end_src
|
||||
|
||||
* Phase E: Lifecycle
|
||||
@@ -240,7 +287,7 @@ The doctor skill should be loaded early (priority 100) to validate system health
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-diagnostics
|
||||
(defskill :passepartout-symbolic-diagnostics
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
349
org/symbolic-events.org
Normal file
349
org/symbolic-events.org
Normal file
@@ -0,0 +1,349 @@
|
||||
#+TITLE: SKILL: Event Orchestrator (symbolic-events.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:orchestrator:hooks:cron:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-events.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Event Orchestrator unifies three control-plane mechanisms that were previously scattered across the system:
|
||||
|
||||
1. **Hooks** — actions triggered when Org nodes with specific ~#+HOOK:~ properties are modified
|
||||
2. **Cron** — time-based scheduled jobs using Org-mode timestamp repeat expressions
|
||||
3. **Routing** — three-tier complexity classifier that decides whether a job needs the LLM at all
|
||||
|
||||
Before the Orchestrator, each of these was handled ad-hoc. The heartbeat thread injected raw ~:heartbeat~ signals that skills had to parse themselves. Memory auto-save was a hardcoded counter in ~core-loop~. There was no way to say "when this file changes, verify its integrity" or "archive old tasks every Sunday."
|
||||
|
||||
The Orchestrator attaches to the heartbeat as a deterministic gate (same pattern as the Dispatcher, the Archivist, and every other heartbeat-driven skill). On each tick, it checks the cron registry for due jobs and dispatches them at the appropriate tier.
|
||||
|
||||
** The three tiers:
|
||||
|
||||
| Tier | LLM? | Mechanism | Example |
|
||||
|------|------|-----------|---------|
|
||||
| ~:reflex~ | No | Direct function call | "Run integrity check" |
|
||||
| ~:cognition~ | Light | Injected as user-input | "Summarize today's notes" |
|
||||
| ~:reasoning~ | Full | Injected as user-input | "Plan the project architecture" |
|
||||
|
||||
The default classifier uses keywords in the context to determine the tier: ~rm~, ~write-file~, ~shell~ → ~:reflex~; ~summarize~, ~list~, ~find~ → ~:cognition~; everything else → ~:reasoning~. This can be overridden by setting ~*tier-classifier*~ to a custom function.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package definition
|
||||
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout.symbolic-events
|
||||
(:use :cl :passepartout)
|
||||
(:export
|
||||
:orchestrator-register-hook
|
||||
:orchestrator-register-cron
|
||||
:orchestrator-classify
|
||||
:orchestrator-on-heartbeat
|
||||
:orchestrator-bootstrap
|
||||
:orchestrator-dispatch
|
||||
:default-classifier
|
||||
:parse-org-repeat
|
||||
:*hook-registry*
|
||||
:*cron-registry*
|
||||
:*tier-classifier*))
|
||||
|
||||
(in-package :passepartout.symbolic-events)
|
||||
#+end_src
|
||||
|
||||
** Registries
|
||||
|
||||
The hook registry maps Org-mode property names (like ~verify-integrity~ from a ~#+HOOK: verify-integrity~ headline property) to lists of gate function symbols. When a node with that hook is modified, the orchestrator calls each gate in sequence.
|
||||
|
||||
The cron registry maps job names (keywords like ~:weekly-report~) to configuration plists. Each entry contains the repeat expression, the action function, and the dispatch tier.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *hook-registry* (make-hash-table :test 'equal)
|
||||
"Maps hook property string → list of gate function symbols.")
|
||||
|
||||
#+end_src
|
||||
** *cron-registry*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *cron-registry* (make-hash-table :test 'equal)
|
||||
"Maps job name string → plist (:next-run :expression :repeat :action :tier).")
|
||||
|
||||
#+end_src
|
||||
** *tier-classifier*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *tier-classifier* nil
|
||||
"Optional function (context) → :reflex | :cognition | :reasoning.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Default tier classifier
|
||||
|
||||
Uses keyword matching on the context text to determine which tier to dispatch at. The matching is deliberately coarse — it's a heuristic, not an exact science. Users who need precise control can set ~*tier-classifier*~ to their own function.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun default-classifier (context)
|
||||
"Rule-based tier classification.
|
||||
:reflex — file/shell operations, deterministic checks
|
||||
:cognition — text processing, summarization, simple Q&A
|
||||
:reasoning — planning, analysis, multi-step decisions"
|
||||
(let* ((text (or (getf context :text) ""))
|
||||
(lower (string-downcase text)))
|
||||
(cond
|
||||
((or (search "rm " lower)
|
||||
(search "write-file" lower)
|
||||
(search "shell" lower)
|
||||
(search "verify-" lower))
|
||||
:reflex)
|
||||
((or (search "summarize" lower)
|
||||
(search "list" lower)
|
||||
(search "find " lower)
|
||||
(search "what is" lower)
|
||||
(search "search" lower))
|
||||
:cognition)
|
||||
(t :reasoning))))
|
||||
#+end_src
|
||||
|
||||
** Parsing Org-mode repeat timestamps
|
||||
|
||||
Org-mode timestamps use the format ~+<2026-05-02 Sat +1w>~ for repeating events. The ~+1w~ means "repeat every week," ~+1d~ means "every day," etc. This function extracts the repeat unit and value.
|
||||
|
||||
Returns ~(UNIT VALUE)~ like ~(:W 1)~ for weekly, or ~NIL~ if there's no repeat clause.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun parse-org-repeat (timestamp-string)
|
||||
(let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string))
|
||||
(parts (uiop:split-string cleaned :separator '(#\space)))
|
||||
(repeat-part (ignore-errors (car (last parts)))))
|
||||
(when (and repeat-part (uiop:string-prefix-p "+" repeat-part))
|
||||
(let* ((rest (subseq repeat-part 1))
|
||||
(num-end (position-if (lambda (c) (not (digit-char-p c))) rest))
|
||||
(num (parse-integer (subseq rest 0 num-end)))
|
||||
(unit-str (subseq rest num-end)))
|
||||
(list (intern (string-upcase unit-str) :keyword) num)))))
|
||||
#+end_src
|
||||
|
||||
** Registering a hook
|
||||
|
||||
Called at boot or when a new ~#+HOOK:~ property is discovered. Appends the gate function to the registry entry for that hook.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-register-hook (hook-property gate-function)
|
||||
"Registers a deterministic gate to fire when an Org node with
|
||||
the #+HOOK: property matching HOOK-PROPERTY is modified."
|
||||
(push gate-function
|
||||
(gethash (string-downcase (string hook-property)) *hook-registry*))
|
||||
(log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function))
|
||||
#+end_src
|
||||
|
||||
** Registering a cron job
|
||||
|
||||
Each cron job has a name, an Org-mode timestamp with optional repeat, an action function, and a dispatch tier. The ~:next-run~ field is initialized to the current time so the job fires on the first heartbeat cycle (it will be rescheduled according to the repeat pattern after execution).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-register-cron (name expression action-function tier)
|
||||
"Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode
|
||||
timestamp string with optional repeat. TIER is :reflex :cognition :reasoning."
|
||||
(let* ((repeat (parse-org-repeat expression))
|
||||
(now (get-universal-time)))
|
||||
(setf (gethash (string-downcase (string name)) *cron-registry*)
|
||||
(list :next-run now
|
||||
:expression expression
|
||||
:repeat repeat
|
||||
:action action-function
|
||||
:tier tier))
|
||||
(log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)"
|
||||
name tier repeat)))
|
||||
#+end_src
|
||||
|
||||
** Dispatch
|
||||
|
||||
Routes an action to the appropriate executor based on its tier. Reflex actions are called directly (deterministic, no LLM overhead). Cognition and reasoning actions are injected as user-input events, which triggers the normal Perceive → Reason → Act pipeline (but at different model tiers).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-dispatch (action tier)
|
||||
"Execute ACTION at the specified TIER."
|
||||
(flet ((safe-inject (text)
|
||||
(when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout))
|
||||
(funcall (find-symbol "STIMULUS-INJECT" :passepartout)
|
||||
(list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text))))))
|
||||
(ecase tier
|
||||
(:reflex
|
||||
(if (functionp action)
|
||||
(funcall action)
|
||||
(when (and (symbolp action) (fboundp action))
|
||||
(funcall action)))
|
||||
:dispatched)
|
||||
(:cognition
|
||||
(safe-inject (format nil "~a" action))
|
||||
:injected)
|
||||
(:reasoning
|
||||
(safe-inject (format nil "~a" action))
|
||||
:injected))))
|
||||
#+end_src
|
||||
|
||||
** Heartbeat handler
|
||||
|
||||
Called on each heartbeat cycle. Checks the cron registry for jobs whose ~:next-run~ time has passed, dispatches them, and reschedules repeating jobs.
|
||||
|
||||
The rescheduling computes the next run based on the repeat unit: ~:d~ (days), ~:w~ (weeks), ~:m~ (months), defaulting to ~:h~ (hours). This is deliberately simple — full calendar-aware scheduling (skip weekends, respect business hours) can be added later.
|
||||
|
||||
Returns ~nil~ so it doesn't block the heartbeat signal from reaching other skills.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-on-heartbeat (context)
|
||||
"Called on each heartbeat tick. Checks and dispatches due cron jobs."
|
||||
(declare (ignore context))
|
||||
(let ((now (get-universal-time))
|
||||
(due-jobs nil))
|
||||
(maphash (lambda (name config)
|
||||
(let ((next-run (getf config :next-run)))
|
||||
(when (>= now next-run)
|
||||
(push (cons name config) due-jobs))))
|
||||
*cron-registry*)
|
||||
(dolist (job due-jobs)
|
||||
(let* ((name (car job))
|
||||
(config (cdr job))
|
||||
(action (getf config :action))
|
||||
(tier (getf config :tier))
|
||||
(repeat (getf config :repeat))
|
||||
(result (orchestrator-dispatch action tier)))
|
||||
(log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a"
|
||||
name tier result)
|
||||
(when repeat
|
||||
(let* ((unit (first repeat))
|
||||
(value (second repeat))
|
||||
(interval (case unit
|
||||
(:d (* 86400 value))
|
||||
(:w (* 604800 value))
|
||||
(:m (* 2592000 value))
|
||||
(t (* 3600 value)))))
|
||||
(setf (getf (gethash name *cron-registry*) :next-run)
|
||||
(+ now interval))))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Bootstrap
|
||||
|
||||
Scans all Org files in the memex for ~#+HOOK:~ and ~#+CRON:~ properties in
|
||||
headline property drawers and auto-registers them.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-scan-org-file (filepath)
|
||||
"Scans a single Org file for HOOK and CRON properties in property drawers.
|
||||
Returns a list of plists (:type :hook/:cron :name <str> :value <str>)."
|
||||
(let ((results nil)
|
||||
(in-properties nil)
|
||||
(lines nil))
|
||||
(handler-case
|
||||
(setf lines (uiop:split-string (uiop:read-file-string filepath)
|
||||
:separator '(#\Newline)))
|
||||
(error (c)
|
||||
(log-message "ORCHESTRATOR: Could not read ~a: ~a" filepath c)
|
||||
(return-from orchestrator-scan-org-file nil)))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (string= trimmed ":PROPERTIES:")
|
||||
(setf in-properties t))
|
||||
(when (string= trimmed ":END:")
|
||||
(setf in-properties nil))
|
||||
(when in-properties
|
||||
(cond
|
||||
((uiop:string-prefix-p ":HOOK:" trimmed)
|
||||
(let ((val (string-trim '(#\Space) (subseq trimmed 6))))
|
||||
(push (list :type :hook :name val :file filepath) results)
|
||||
(log-message "ORCHESTRATOR: Found hook ~a in ~a" val filepath)))
|
||||
((uiop:string-prefix-p ":CRON:" trimmed)
|
||||
(let ((val (string-trim '(#\Space) (subseq trimmed 6))))
|
||||
(push (list :type :cron :name val :file filepath) results)
|
||||
(log-message "ORCHESTRATOR: Found cron ~a in ~a" val filepath)))))))
|
||||
(nreverse results)))
|
||||
|
||||
#+end_src
|
||||
** orchestrator-bootstrap
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-bootstrap ()
|
||||
"Scans all Org files in the memex for #+HOOK: and #+CRON: properties
|
||||
and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(scan-dirs (list (merge-pathnames "projects/" memex-dir)
|
||||
(merge-pathnames "system/" memex-dir)))
|
||||
(hook-count 0)
|
||||
(cron-count 0))
|
||||
(dolist (dir scan-dirs)
|
||||
(handler-case
|
||||
(let ((files (uiop:directory-files dir "*.org")))
|
||||
(dolist (file files)
|
||||
(let* ((path (namestring file))
|
||||
(entries (orchestrator-scan-org-file path)))
|
||||
(dolist (entry entries)
|
||||
(let ((type (getf entry :type))
|
||||
(name (getf entry :name)))
|
||||
(cond
|
||||
((eq type :hook)
|
||||
(orchestrator-register-hook name
|
||||
(lambda ()
|
||||
(log-message "ORCHESTRATOR: Hook ~a fired" name))))
|
||||
((eq type :cron)
|
||||
(orchestrator-register-cron
|
||||
(intern (string-upcase (format nil "cron-~a" name)) :keyword)
|
||||
name
|
||||
(lambda ()
|
||||
(log-message "ORCHESTRATOR: Cron ~a fired" name))
|
||||
:cognition))))
|
||||
(if (eq (getf entry :type) :hook) (incf hook-count) (incf cron-count))))))
|
||||
(error (c)
|
||||
(log-message "ORCHESTRATOR: Could not scan ~a: ~a" dir c))))
|
||||
(log-message "ORCHESTRATOR: Bootstrap complete (~d hooks, ~d cron jobs)"
|
||||
hook-count cron-count)))
|
||||
#+end_src
|
||||
|
||||
** Heartbeat Generation (events-start-heartbeat)
|
||||
|
||||
The heartbeat generator was extracted from ~core-pipeline.lisp~ in v0.5.0. It creates a background thread that periodically injects ~:heartbeat~ signals into the pipeline.
|
||||
|
||||
If heartbeat is corrupted or missing, the agent has no background ticks — no cron jobs, no auto-save. But it remains fully functional: degraded, not dead. This is the self-repair criterion.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun events-start-heartbeat ()
|
||||
"Starts the background heartbeat thread. v0.5.0: extracted from core-loop."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) passepartout::*memory-auto-save-interval*)))
|
||||
(setf passepartout::*memory-auto-save-interval* auto-save)
|
||||
(setf passepartout::*heartbeat-save-counter* 0)
|
||||
(setf passepartout::*heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf passepartout::*heartbeat-save-counter*)
|
||||
(when (>= passepartout::*heartbeat-save-counter* (/ passepartout::*memory-auto-save-interval* interval))
|
||||
(setf passepartout::*heartbeat-save-counter* 0)
|
||||
(passepartout::save-memory-to-disk))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "passepartout-heartbeat"))))
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
|
||||
The orchestrator registers as a skill with low priority so it runs after critical skills (policy, dispatcher) but before the heartbeat processing. The trigger matches ~:heartbeat~ sensor events.
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-events
|
||||
:priority 80
|
||||
:trigger (lambda (ctx)
|
||||
(eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action context)
|
||||
(declare (ignore action))
|
||||
(orchestrator-on-heartbeat context)
|
||||
nil))
|
||||
#+end_src
|
||||
126
org/symbolic-identity.org
Normal file
126
org/symbolic-identity.org
Normal file
@@ -0,0 +1,126 @@
|
||||
#+TITLE: Symbolic Identity — Agent Self-Concept
|
||||
#+FILETAGS: :skill:identity:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-identity.lisp
|
||||
|
||||
* Overview
|
||||
Load `~/memex/IDENTITY.org` into the agent's self-concept at daemon
|
||||
startup. The identity text is injected into the system prompt's
|
||||
`IDENTITY` section, between assistant name and reflection feedback.
|
||||
|
||||
The file is user-editable and survives restarts. If the file is
|
||||
missing or empty, identity is silently `""` (no-op).
|
||||
|
||||
* Contract
|
||||
|
||||
1. `(load-identity-file &optional path)`:
|
||||
Reads IDENTITY.org from `path` (default `~/memex/IDENTITY.org`).
|
||||
Sets `*agent-identity*` to the file content string.
|
||||
Returns the content string, or NIL if file missing/unreadable.
|
||||
2. `(agent-identity)`:
|
||||
Returns the cached identity string (`*agent-identity*`), or `""` if
|
||||
identity has not been loaded.
|
||||
3. `*agent-identity*`:
|
||||
Special variable holding the loaded identity text (string).
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *agent-identity* ""
|
||||
"Identity text loaded from ~/memex/IDENTITY.org at startup.
|
||||
|
||||
This variable holds the contents of the user's identity file.
|
||||
Loaded by `load-identity-file` at daemon/skill initialization,
|
||||
called from `agent-identity` for system prompt injection.
|
||||
|
||||
The file is user-editable and persists across restarts.
|
||||
If the file is missing or empty, this variable remains \"\".")
|
||||
|
||||
(defun load-identity-file (&optional (path nil path-p))
|
||||
"Load agent identity from an org file.
|
||||
|
||||
Reads the identity text file and caches it in
|
||||
`*agent-identity*`. If PATH is not provided, defaults to
|
||||
`~/memex/IDENTITY.org`.
|
||||
|
||||
Returns the file content string on success, or NIL if the file
|
||||
does not exist or cannot be read."
|
||||
(let* ((file-path (if path-p
|
||||
(uiop:ensure-pathname path :ensure-absolute t)
|
||||
(merge-pathnames "memex/IDENTITY.org"
|
||||
(user-homedir-pathname)))))
|
||||
(when (uiop:file-exists-p file-path)
|
||||
(handler-case
|
||||
(let ((content (uiop:read-file-string file-path)))
|
||||
(setf *agent-identity* content)
|
||||
content)
|
||||
(error () nil)))))
|
||||
|
||||
(defun agent-identity ()
|
||||
"Return the currently loaded agent identity string."
|
||||
(or *agent-identity* ""))
|
||||
|
||||
;; Auto-load identity at skill init
|
||||
(load-identity-file)
|
||||
|
||||
#+end_src
|
||||
|
||||
* Test Squad
|
||||
** Test Package
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout-identity-tests
|
||||
(:use :common-lisp :fiveam :passepartout)
|
||||
(:export :identity-suite))
|
||||
#+end_src
|
||||
|
||||
** Test Suite
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-identity-tests)
|
||||
|
||||
(def-suite identity-suite
|
||||
:description "Agent identity loading and caching")
|
||||
(in-suite identity-suite)
|
||||
|
||||
(test test-load-identity-file-returns-content
|
||||
"Contract 1: load-identity-file reads an existing file, returns content."
|
||||
(let* ((path "/tmp/memex-test-identity.org")
|
||||
(content "### Personality
|
||||
- Friendly
|
||||
- Concise"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(let ((result (passepartout::load-identity-file path)))
|
||||
(is (stringp result))
|
||||
(is (search "Friendly" result))
|
||||
(is (search "Concise" result)))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-load-identity-file-missing-nil
|
||||
"Contract 1: nil when file does not exist."
|
||||
(let ((result (passepartout::load-identity-file
|
||||
"/tmp/memex-nonexistent-xxxx.org")))
|
||||
(is (null result))))
|
||||
|
||||
(test test-agent-identity-cached
|
||||
"Contract 2+3: agent-identity returns cached value after load."
|
||||
(let* ((path "/tmp/memex-test-identity2.org")
|
||||
(content "### Preferences
|
||||
- Use shell cautiously"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(passepartout::load-identity-file path)
|
||||
(let ((id (passepartout::agent-identity)))
|
||||
(is (search "shell cautiously" id))))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-agent-identity-empty-default
|
||||
"Contract 2: returns empty string when nothing was loaded."
|
||||
(let ((prev passepartout::*agent-identity*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*agent-identity* nil)
|
||||
(is (string= "" (passepartout::agent-identity))))
|
||||
(setf passepartout::*agent-identity* prev))))
|
||||
#+end_src
|
||||
92
org/symbolic-memory.org
Normal file
92
org/symbolic-memory.org
Normal file
@@ -0,0 +1,92 @@
|
||||
#+TITLE: SKILL: Homoiconic Memory (org-skill-homoiconic-memory.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :harness:memory:homoiconic:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-memory.lisp
|
||||
|
||||
* Overview
|
||||
Because Lisp is homoiconic (code is data), memory objects can be read as executable forms. This skill provides the bridge between the org-object store and live Lisp evaluation — it can serialize an org-object into an s-expression, evaluate it to reconstruct state, and store the result back as a new object. This is the foundation of the agent's ability to save, restore, and inspect its own cognitive state at runtime.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Memory Inspection
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10))
|
||||
"Returns a structured report of memory state.
|
||||
Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string).
|
||||
Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
:recent <list> :snapshots <n> :orphans <n>)."
|
||||
(let* ((store (if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(return-from memory-inspect
|
||||
(list :total 0 :reason "Memory store not available"))))
|
||||
(total 0)
|
||||
(type-counts (make-hash-table :test 'eq))
|
||||
(todo-counts (make-hash-table :test 'equal))
|
||||
(recent nil)
|
||||
(all-ids (make-hash-table :test 'equal))
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((obj-type (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq obj-type type-filter)))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when (and todo-filter
|
||||
(not (string-equal todo todo-filter)))
|
||||
(return nil)))
|
||||
(incf total)
|
||||
(incf (gethash obj-type type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
(push (list :id id
|
||||
:type t
|
||||
:todo (getf attrs :TODO-STATE)
|
||||
:title (getf attrs :TITLE)
|
||||
:version v)
|
||||
recent))))
|
||||
store)
|
||||
;; Sort recent by version desc and take LIMIT
|
||||
(setf recent (subseq (sort recent #'>
|
||||
:key (lambda (r) (or (getf r :version) 0)))
|
||||
0 (min limit (length recent))))
|
||||
;; Count orphans
|
||||
(maphash (lambda (id obj)
|
||||
(let ((parent (memory-object-parent-id obj)))
|
||||
(when (and parent (not (gethash parent all-ids)))
|
||||
(incf orphans))))
|
||||
store)
|
||||
;; Build output
|
||||
(let ((types (loop for k being the hash-keys of type-counts
|
||||
using (hash-value v)
|
||||
collect (cons k v)))
|
||||
(todos (loop for k being the hash-keys of todo-counts
|
||||
using (hash-value v)
|
||||
collect (cons k v)))
|
||||
(snapshots (if (boundp '*memory-snapshots*)
|
||||
(length (symbol-value '*memory-snapshots*))
|
||||
0)))
|
||||
(list :total total
|
||||
:by-type (sort types #'> :key #'cdr)
|
||||
:by-todo (sort todos #'> :key #'cdr)
|
||||
:recent recent
|
||||
:snapshots snapshots
|
||||
:orphans orphans))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-memory
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :introspection))
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action ctx))
|
||||
(ignore-errors (memory-inspect))
|
||||
nil))
|
||||
#+end_src
|
||||
363
org/symbolic-scope.org
Normal file
363
org/symbolic-scope.org
Normal file
@@ -0,0 +1,363 @@
|
||||
#+TITLE: SKILL: Context Manager (org-skill-context-manager.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:context:scoping:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-scope.lisp
|
||||
|
||||
* Overview
|
||||
|
||||
The Context Manager provides stack-based project focusing. When the agent
|
||||
"focuses" on a project, file paths resolve relative to it and memory queries
|
||||
auto-filter by scope. This enables the agent to work within a bounded context
|
||||
without being distracted by unrelated memory.
|
||||
|
||||
The core provides the mechanism (=memory-object-scope=, =context-query= with
|
||||
scope parameter). This skill provides the policy — what to focus on, what
|
||||
scope means for each project, and how the stack is managed.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (push-context &key project base-path scope): pushes a context plist
|
||||
onto ~*context-stack*~. Blocks if depth exceeds ~*context-max-depth*~.
|
||||
2. (pop-context): pops and returns the top context. If the stack would
|
||||
become empty, inserts a default memex-wide context instead.
|
||||
3. (current-context): returns the top-of-stack context plist.
|
||||
4. (current-scope): returns the ~:scope~ keyword from the current context.
|
||||
5. (current-project): returns the ~:project~ name from the current context.
|
||||
6. (current-base-path): returns the ~:base-path~ from the current context.
|
||||
7. (context-stack-depth): returns the number of contexts on the stack.
|
||||
8. (focus-project name base-path): pushes a new context for the named
|
||||
project. Sets ~*scope-resolver*~ to return ~:project~.
|
||||
9. (focus-session): pushes an ephemeral context for the current session.
|
||||
10. (focus-memex): pushes a global memex-wide context.
|
||||
11. (unfocus): pops one level from the context stack.
|
||||
12. (resolve-path path): resolves a path relative to the current base-path.
|
||||
13. (context-scoped-query &key tag todo-state type): queries memory filtered
|
||||
by the current context's scope.
|
||||
14. (context-save): persists the context stack to disk.
|
||||
15. (context-load): restores the context stack from disk on startup.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Context Stack
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *context-stack* nil
|
||||
"Stack of context plists. Each plist has :project, :base-path, :scope.
|
||||
Top of stack (car) is the current context.")
|
||||
|
||||
#+end_src
|
||||
** *context-max-depth*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *context-max-depth* 10
|
||||
"Maximum context stack depth. Prevents runaway pushes.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Context Accessors
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-context ()
|
||||
"Returns the current context plist, or nil if no context is set."
|
||||
(car *context-stack*))
|
||||
|
||||
#+end_src
|
||||
** current-scope
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-scope ()
|
||||
"Returns the current scope keyword (:memex/:session/:project).
|
||||
Returns :memex when no context is set (defaults to global scope)."
|
||||
(or (getf (current-context) :scope) :memex))
|
||||
|
||||
#+end_src
|
||||
** current-project
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-project ()
|
||||
"Returns the current project name, or nil."
|
||||
(getf (current-context) :project))
|
||||
|
||||
#+end_src
|
||||
** current-base-path
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-base-path ()
|
||||
"Returns the current base path for file resolution, or nil."
|
||||
(getf (current-context) :base-path))
|
||||
|
||||
#+end_src
|
||||
** context-stack-depth
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-stack-depth ()
|
||||
"Returns the current depth of the context stack."
|
||||
(length *context-stack*))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Stack Operations
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun push-context (&key project base-path (scope :project))
|
||||
"Pushes a new context onto the stack. When focused on a project:
|
||||
- File paths resolve relative to BASE-PATH
|
||||
- Memory queries filter by SCOPE
|
||||
- :memex scope objects remain visible (always global)
|
||||
Returns the new context plist."
|
||||
(when (>= (context-stack-depth) *context-max-depth*)
|
||||
(log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*)
|
||||
(return-from push-context (current-context)))
|
||||
(let* ((context (list :project project
|
||||
:base-path base-path
|
||||
:scope scope)))
|
||||
(push context *context-stack*)
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth))
|
||||
context))
|
||||
|
||||
#+end_src
|
||||
** pop-context
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun pop-context ()
|
||||
"Pops the current context, restoring the previous one.
|
||||
Returns the restored context or nil if stack becomes empty."
|
||||
(if *context-stack*
|
||||
(let ((popped (pop *context-stack*)))
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Popped ~a (depth ~d)"
|
||||
(getf popped :project) (context-stack-depth))
|
||||
(current-context))
|
||||
(progn
|
||||
(log-message "CONTEXT: Cannot pop — stack is empty")
|
||||
nil)))
|
||||
|
||||
#+end_src
|
||||
** with-context
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defmacro with-context ((&key project base-path (scope :project)) &body body)
|
||||
"Executes BODY within a scoped context, then restores the previous context.
|
||||
Example:
|
||||
(with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\")
|
||||
(context-scoped-query :tag \"bug\"))"
|
||||
`(let ((*context-stack* (cons (list :project ,project
|
||||
:base-path ,base-path
|
||||
:scope ,scope)
|
||||
*context-stack*)))
|
||||
,@body))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Path Resolution
|
||||
|
||||
Resolves file paths relative to the current project's base path.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun resolve-path (path)
|
||||
"Resolves a file path relative to the current context.
|
||||
If PATH is absolute, returns it unchanged.
|
||||
If PATH is relative and a base-path is set, merges them.
|
||||
Otherwise returns PATH unchanged."
|
||||
(let ((base (current-base-path)))
|
||||
(if (and base path (not (uiop:absolute-pathname-p path)))
|
||||
(namestring (merge-pathnames path (uiop:ensure-directory-pathname base)))
|
||||
path)))
|
||||
#+end_src
|
||||
|
||||
** Memory Scope Filtering
|
||||
|
||||
Provides scope-aware query access. When a context is active (scope ≠ :memex),
|
||||
queries only return objects whose scope is :memex (global) or matches the
|
||||
current scope.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-scoped-query (&key tag todo-state type)
|
||||
"Like context-query but filtered to the current context's scope.
|
||||
:memex-scoped objects are always visible regardless of current scope."
|
||||
(context-query :tag tag :todo-state todo-state :type type :scope (current-scope)))
|
||||
|
||||
#+end_src
|
||||
** project-objects
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun project-objects ()
|
||||
"Returns all objects scoped to the current project.
|
||||
Includes :memex-scoped objects (global knowledge) plus :project-scoped
|
||||
objects matching the current project."
|
||||
(context-scoped-query))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Project Focus Convenience
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-project (name base-path)
|
||||
"Shortcut: focus on a project by name and base path.
|
||||
Calls push-context with :scope :project."
|
||||
(push-context :project name :base-path base-path :scope :project))
|
||||
|
||||
#+end_src
|
||||
** focus-session
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-session ()
|
||||
"Shortcut: enter a session context (ephemeral scope).
|
||||
Objects created in this scope are visible only during the session."
|
||||
(push-context :project "session" :scope :session))
|
||||
|
||||
#+end_src
|
||||
** focus-memex
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-memex ()
|
||||
"Shortcut: return to global memex scope. Equivalent to pop-context
|
||||
until stack is empty or :memex context is reached."
|
||||
(loop while (and *context-stack*
|
||||
(not (eq (getf (current-context) :scope) :memex)))
|
||||
do (pop-context)))
|
||||
|
||||
#+end_src
|
||||
** unfocus
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun unfocus ()
|
||||
"Pop the top context and return to the previous one."
|
||||
(pop-context))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
** Persistence
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-05T12:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *context-persistence-file* nil
|
||||
"Path to the context stack persistence file.")
|
||||
|
||||
(defun context-persist-file ()
|
||||
"Returns the full path to the context persistence file."
|
||||
(or *context-persistence-file*
|
||||
(setf *context-persistence-file*
|
||||
(merge-pathnames ".cache/passepartout/context.lisp"
|
||||
(user-homedir-pathname)))))
|
||||
|
||||
(defun context-save ()
|
||||
"Writes *context-stack* to the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(ensure-directories-exist (make-pathname :directory (pathname-directory path)))
|
||||
(with-open-file (s path :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(prin1 *context-stack* s))
|
||||
(log-message "CONTEXT: Saved stack (depth ~d) to ~a"
|
||||
(length *context-stack*) path))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to save: ~a" c))))
|
||||
|
||||
(defun context-load ()
|
||||
"Restores *context-stack* from the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(when (probe-file path)
|
||||
(with-open-file (s path :direction :input)
|
||||
(let ((*read-eval* nil)
|
||||
(data (read s nil nil)))
|
||||
(when (listp data)
|
||||
(setf *context-stack* data)
|
||||
(log-message "CONTEXT: Restored stack (depth ~d) from ~a"
|
||||
(length *context-stack*) path))
|
||||
t))))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to load: ~a" c)
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-scope
|
||||
:priority 90
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action))
|
||||
(ignore-errors
|
||||
(when (> (context-stack-depth) 0)
|
||||
nil))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Auto-Init: Wire Scope Resolver
|
||||
|
||||
Registers ~current-scope~ into the core ~*scope-resolver*~ hook so the
|
||||
perceive gate tags ingested objects with the active context scope.
|
||||
Also restores any previously saved context stack.
|
||||
|
||||
#+begin_src lisp
|
||||
(when (boundp '*scope-resolver*)
|
||||
(setf *scope-resolver* #'current-scope))
|
||||
|
||||
;; Restore persisted context on load
|
||||
(context-load)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
#+end_src* Contract
|
||||
|
||||
1. (push-context &key project base-path scope): pushes a context plist
|
||||
onto ~*context-stack*~ and persists to disk.
|
||||
2. (pop-context): pops the top context, persists, returns restored context.
|
||||
3. (context-save): serializes ~*context-stack*~ to the persistence file.
|
||||
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
|
||||
280
org/symbolic-self-improve.org
Normal file
280
org/symbolic-self-improve.org
Normal file
@@ -0,0 +1,280 @@
|
||||
#+TITLE: SKILL: Self-Improve (org-skill-self-improve.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:autonomy:self-improve:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-self-improve.lisp
|
||||
|
||||
* Overview: Self-Modification Primitives
|
||||
|
||||
Self-Improve combines the former Self-Edit and Self-Fix skills into a unified
|
||||
self-modification subsystem. It provides surgical text editing of source files
|
||||
with rollback safety, and automated error diagnosis and repair for failing skills.
|
||||
|
||||
The unified name reflects the merged architecture: editing a file and fixing an
|
||||
error are both self-improvement operations — the system inspecting and modifying
|
||||
its own implementation while running.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Infrastructure: Org Tangle Utility
|
||||
|
||||
Reads an Org file's ~#+PROPERTY: header-args:lisp :tangle~ line, extracts
|
||||
all ~#+begin_src lisp~ blocks, writes them to the target ~.lisp~ file, and
|
||||
compiles+loads the result. Used by the self-improve functions to propagate
|
||||
edits and repairs to the running daemon.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-tangle-file (filepath)
|
||||
"Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads."
|
||||
(let ((content (uiop:read-file-string filepath))
|
||||
(tangle-path nil)
|
||||
(lisp-lines nil)
|
||||
(in-block nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((and (null tangle-path)
|
||||
(search "#+PROPERTY:" trimmed)
|
||||
(search ":tangle" trimmed))
|
||||
(let* ((parts (uiop:split-string trimmed :separator '(#\Space)))
|
||||
(target (car (last parts)))
|
||||
(org-dir (make-pathname :directory (pathname-directory filepath))))
|
||||
(when (and target (not (string-equal target "no")))
|
||||
(setf tangle-path
|
||||
(if (char= (aref target 0) #\/)
|
||||
(uiop:parse-unix-namestring target)
|
||||
(uiop:parse-unix-namestring
|
||||
(format nil "~a/~a" (namestring org-dir) target)))))))
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t))
|
||||
((search "#+end_src" trimmed)
|
||||
(setf in-block nil)
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) lisp-lines))))
|
||||
(in-block
|
||||
(push line lisp-lines)))))
|
||||
(when (and tangle-path lisp-lines)
|
||||
(setf lisp-lines (nreverse lisp-lines))
|
||||
(ensure-directories-exist tangle-path)
|
||||
(with-open-file (f tangle-path :direction :output :if-exists :supersede)
|
||||
(format f "~{~a~%~}" lisp-lines))
|
||||
(let ((compiled (compile-file tangle-path)))
|
||||
(when compiled
|
||||
(load compiled)
|
||||
(list :tangled (namestring tangle-path) :compiled t))))))
|
||||
#+end_src
|
||||
|
||||
** Infrastructure: Org Lisp Block Extractor
|
||||
|
||||
Extracts all ~#+begin_src lisp~ block contents from an Org content string,
|
||||
returning a list of code strings. Used by repair functions to iterate over
|
||||
blocks and apply syntactic fixes.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings."
|
||||
(let ((blocks nil)
|
||||
(in-block nil)
|
||||
(current nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t current nil))
|
||||
((search "#+end_src" trimmed)
|
||||
(when in-block
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) current)))
|
||||
(push (format nil "~{~a~%~}" (nreverse current)) blocks)
|
||||
(setf in-block nil current nil)))
|
||||
(in-block
|
||||
(push line current)))))
|
||||
(nreverse blocks)))
|
||||
#+end_src
|
||||
|
||||
** Self-Edit: Surgical Text Transformation
|
||||
|
||||
Applies a search-and-replace edit to a file, verifies the edit took effect,
|
||||
and if the file is an ~.org~ file, automatically tangles it to ~.lisp~ and
|
||||
reloads the compiled result into the running daemon. A memory snapshot is
|
||||
taken before the edit for rollback safety.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-edit (filepath old-text new-text)
|
||||
"Surgical text replacement with tangle+reload for Org source files."
|
||||
(when (or (null filepath) (null old-text) (null new-text))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason "Missing arguments")))
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason (format nil "File not found: ~a" filepath))))
|
||||
(log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text))
|
||||
(ignore-errors
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(pos (search old-text content)))
|
||||
(if pos
|
||||
(let* ((new-content (concatenate 'string
|
||||
(subseq content 0 pos)
|
||||
new-text
|
||||
(subseq content (+ pos (length old-text)))))
|
||||
(ext (pathname-type filepath)))
|
||||
(with-open-file (f filepath :direction :output :if-exists :supersede)
|
||||
(write-sequence new-content f))
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test 'string=)
|
||||
(let ((tangle-result
|
||||
(when (string-equal ext "org")
|
||||
(ignore-errors (org-tangle-file filepath)))))
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a"
|
||||
(length old-text) filepath)
|
||||
:tangle tangle-result))
|
||||
(list :status :error :reason "Verification failed"))))
|
||||
(list :status :error :reason
|
||||
(format nil "Text not found in ~a" filepath)))))
|
||||
#+end_src
|
||||
|
||||
** Paren Balancer
|
||||
|
||||
Utility that attempts to fix unbalanced parentheses in a Lisp code string.
|
||||
If the code is already balanced, returns nil. Otherwise counts open vs close
|
||||
parens and appends missing closing parens.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-balance-parens (code)
|
||||
"Returns balanced code or nil if already balanced."
|
||||
(handler-case
|
||||
(progn
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values))
|
||||
nil)
|
||||
(error ()
|
||||
(let* ((opens (loop for ch across code count (char= ch #\()))
|
||||
(closes (loop for ch across code count (char= ch #\))))
|
||||
(missing (- opens closes)))
|
||||
(when (plusp missing)
|
||||
(concatenate 'string code
|
||||
(make-string missing :initial-element #\))))))))
|
||||
#+end_src
|
||||
|
||||
** Syntax Repair Driver
|
||||
|
||||
Given a skill name, locates its ~.org~ source file, extracts all Lisp blocks,
|
||||
runs each through the paren balancer, writes fixes back to the file, tangles,
|
||||
compiles, and reloads.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-repair-syntax (skill-name)
|
||||
"Find and fix unbalanced parens in a skill's Org source file."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname
|
||||
(or (uiop:getenv "PASSEPARTOUT_DATA_DIR")
|
||||
(merge-pathnames ".local/share/passepartout/"
|
||||
(user-homedir-pathname)))))
|
||||
(org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir)))
|
||||
(unless (uiop:file-exists-p org-path)
|
||||
(return-from self-improve-repair-syntax
|
||||
(list :status :error :reason (format nil "Source not found: ~a" skill-name)
|
||||
:repaired nil)))
|
||||
(let* ((content (uiop:read-file-string org-path))
|
||||
(blocks (org-extract-lisp-blocks content))
|
||||
(fixed 0) (result content))
|
||||
(dolist (block blocks)
|
||||
(let ((balanced (self-improve-balance-parens block)))
|
||||
(when (and balanced (not (string= block balanced)))
|
||||
(let ((pos (search block result)))
|
||||
(when pos
|
||||
(setf result (concatenate 'string
|
||||
(subseq result 0 pos)
|
||||
balanced
|
||||
(subseq result (+ pos (length block))))
|
||||
fixed (1+ fixed)))))))
|
||||
(if (> fixed 0)
|
||||
(progn
|
||||
(with-open-file (f org-path :direction :output :if-exists :supersede)
|
||||
(write-sequence result f))
|
||||
(let ((tangle-result (org-tangle-file org-path)))
|
||||
(list :status :success
|
||||
:action (format nil "Fixed ~d block(s) in ~a" fixed skill-name)
|
||||
:repaired t :tangle tangle-result)))
|
||||
(list :status :error
|
||||
:reason (format nil "No unbalanced blocks in ~a" skill-name)
|
||||
:repaired nil)))))
|
||||
#+end_src
|
||||
|
||||
** Self-Fix: Error Diagnosis and Repair
|
||||
|
||||
Parses an error log to diagnose the error type, then dispatches to the
|
||||
appropriate repair function. Currently supports syntax error repair
|
||||
(unbalanced parentheses). Other error types return a diagnosis without
|
||||
automatic repair.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-fix (skill-name error-log)
|
||||
"Diagnoses and attempts to repair a failing skill."
|
||||
(when (or (null skill-name) (null error-log))
|
||||
(return-from self-improve-fix
|
||||
(list :status :error :reason "Missing arguments: skill-name and error-log required")))
|
||||
(log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name)
|
||||
(let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log)))
|
||||
(diagnosis nil)
|
||||
(extracted-type nil))
|
||||
(cond
|
||||
((search "Reader Error" log-str :test 'char-equal)
|
||||
(setf extracted-type :syntax-error
|
||||
diagnosis (list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test 'char-equal)
|
||||
(setf extracted-type :undefined-symbol
|
||||
diagnosis (list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test 'char-equal)
|
||||
(setf extracted-type :package-error
|
||||
diagnosis (list :type :package-error
|
||||
:detail "Package resolution error"
|
||||
:log log-str)))
|
||||
(t
|
||||
(setf extracted-type :unknown
|
||||
diagnosis (list :type :unknown
|
||||
:detail (format nil "Unrecognized error: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name extracted-type)
|
||||
(let ((repair-result
|
||||
(when (eql extracted-type :syntax-error)
|
||||
(self-improve-repair-syntax skill-name))))
|
||||
(if (and repair-result (getf repair-result :repaired))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Successfully repaired ~a" skill-name)
|
||||
repair-result)
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name
|
||||
(getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
Registered with a trigger on ~:LOG~ and ~:EVENT~ context types. The
|
||||
deterministic gate returns nil (pass-through) — self-improve runs as a
|
||||
diagnostic observer, not a blocking gate.
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-symbolic-self-improve
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT)))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
#+end_src
|
||||
156
org/symbolic-time-memory.org
Normal file
156
org/symbolic-time-memory.org
Normal file
@@ -0,0 +1,156 @@
|
||||
#+TITLE: Symbolic Time Memory — temporal memory queries
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:time:memory:v0.6.0:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/symbolic-time-memory.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
Every ~memory-object~ carries a ~version~ timestamp (~get-universal-time~) set on
|
||||
ingest since v0.1.0. But ~context-query~ in ~symbolic-awareness~ has no time
|
||||
filter — "what did I work on today?" serializes all nodes to the LLM instead
|
||||
of filtering 500→12 in sub-millisecond Lisp.
|
||||
|
||||
This skill adds temporal query primitives and extends ~context-query~ with
|
||||
~:since~ / ~:until~ keyword parameters. Pure Lisp, sub-millisecond, 0 LLM
|
||||
tokens. ~90% token reduction on time-scoped memory queries.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (memory-objects-since timestamp): walks ~*memory-store*~ returning objects
|
||||
with ~version >= timestamp~.
|
||||
2. (memory-objects-in-range since until): returns objects with version between
|
||||
~since~ and ~until~ (inclusive).
|
||||
3. (context-query-with-time &key max-results type filter since until): extends
|
||||
~context-query~ with temporal filtering. Falls back to ~context-query~ for
|
||||
non-time-scoped queries.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Contract 1: memory-objects-since
|
||||
#+begin_src lisp
|
||||
(defun memory-objects-since (timestamp)
|
||||
"Returns all memory-objects from *memory-store* with version >= TIMESTAMP."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (>= (memory-object-version obj) timestamp)
|
||||
(push obj results)))
|
||||
*memory-store*)
|
||||
(nreverse results)))
|
||||
#+end_src
|
||||
|
||||
** Contract 2: memory-objects-in-range
|
||||
#+begin_src lisp
|
||||
(defun memory-objects-in-range (since until)
|
||||
"Returns memory-objects with version between SINCE and UNTIL (inclusive)."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((v (memory-object-version obj)))
|
||||
(when (and (>= v since) (<= v until))
|
||||
(push obj results))))
|
||||
*memory-store*)
|
||||
(nreverse results)))
|
||||
#+end_src
|
||||
|
||||
** Context query extension
|
||||
#+begin_src lisp
|
||||
(defun context-query-with-time (&key (max-results 20) type-filter todo-filter since until)
|
||||
"Extended context query with temporal filtering.
|
||||
When :since and/or :until are provided, filters results by memory-object version.
|
||||
Falls back to context-query if temporal filtering is not requested."
|
||||
(let* ((all (if (fboundp 'memory-objects-by-attribute)
|
||||
(if type-filter
|
||||
(memory-objects-by-attribute :TYPE type-filter)
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(push obj results))
|
||||
*memory-store*)
|
||||
results))
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(push obj results))
|
||||
*memory-store*)
|
||||
results)))
|
||||
(time-filtered (cond
|
||||
((and since until)
|
||||
(remove-if (lambda (obj)
|
||||
(let ((v (memory-object-version obj)))
|
||||
(not (and (>= v since) (<= v until)))))
|
||||
all))
|
||||
(since
|
||||
(remove-if (lambda (obj)
|
||||
(< (memory-object-version obj) since))
|
||||
all))
|
||||
(until
|
||||
(remove-if (lambda (obj)
|
||||
(> (memory-object-version obj) until))
|
||||
all))
|
||||
(t all))))
|
||||
(let ((todo-filtered (if todo-filter
|
||||
(remove-if-not (lambda (obj)
|
||||
(string-equal (getf (memory-object-attributes obj) :TODO-STATE "") todo-filter))
|
||||
time-filtered)
|
||||
time-filtered)))
|
||||
(subseq todo-filtered 0 (min max-results (length todo-filtered))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-time-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:time-memory-suite))
|
||||
|
||||
(in-package :passepartout-time-memory-tests)
|
||||
|
||||
(def-suite time-memory-suite :description "Temporal memory filtering")
|
||||
(in-suite time-memory-suite)
|
||||
|
||||
(test test-memory-objects-since
|
||||
"Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil))
|
||||
(let ((since-t1 (passepartout::memory-objects-since t1)))
|
||||
(is (= 2 (length since-t1)))
|
||||
(let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<)))
|
||||
(is (string= "time-c" (first ids)))
|
||||
(is (string= "time-d" (second ids))))
|
||||
(let ((since-t0 (passepartout::memory-objects-since t0)))
|
||||
(is (= 4 (length since-t0))))))))
|
||||
|
||||
(test test-memory-objects-in-range
|
||||
"Contract 2: ingest nodes, verify range query returns correct subset."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t2 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil))
|
||||
(let ((range (passepartout::memory-objects-in-range t1 t2)))
|
||||
(is (= 1 (length range)))
|
||||
(is (string= "rng-2" (memory-object-id (first range)))))))))
|
||||
#+end_src
|
||||
504
org/system-integration-tests.org
Normal file
504
org/system-integration-tests.org
Normal file
@@ -0,0 +1,504 @@
|
||||
#+TITLE: SKILL: System Integration Tests
|
||||
#+AUTHOR: Agent
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/system-integration-tests.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
Integration tests verify that modules work together over real boundaries —
|
||||
TCP sockets, file I/O, subprocess execution, and the full daemon pipeline.
|
||||
Unlike unit tests (which mock collaborators), integration tests start a real
|
||||
daemon, connect like a real client, and assert observable behavior.
|
||||
|
||||
** Contract
|
||||
|
||||
Phase 1 — In-process daemon (no external credentials):
|
||||
|
||||
1. (start-daemon &key port): binds port, sends handshake on connect.
|
||||
2. Pipeline: a ~:user-input~ event traverses the full pipeline.
|
||||
3. Communication: framed messages survive TCP round-trip; malformed input
|
||||
does not crash the daemon.
|
||||
4. Skill loader: after daemon start, ~*skill-registry*~ is populated.
|
||||
5. Shell actuator: safe commands execute; dangerous patterns are blocked.
|
||||
6. CLI gateway: text injected via TCP reaches the pipeline.
|
||||
7. Gateway registry: ~gateway-registry-initialize~ is available.
|
||||
|
||||
Phase 2 — LLM + messaging:
|
||||
|
||||
8. Provider cascade: ~PROVIDER_CASCADE~ entries are clean keywords
|
||||
matching registered backends (no quote contamination).
|
||||
9. Backend cascade: real provider returns string content.
|
||||
|
||||
Phase 3 — TUI via tmux (rendering diagnostics):
|
||||
|
||||
10. Cascade inspection: ~/eval *provider-cascade*~ shows clean keywords
|
||||
on TUI screen (no quote artifacts from cl-dotenv).
|
||||
11. Eval command: ~/eval (+ 1 2)~ displays ~~=> 3~~ on screen.
|
||||
12. Status bar: rendered screen shows ~~msgs:~~ in status bar.
|
||||
13. Direct render: ~/eval (add-msg :agent ...)~ renders text on screen
|
||||
independent of daemon — isolates TUI rendering from pipeline.
|
||||
14. Daemon roundtrip: daemon LLM response stored in TUI ~~:messages~~
|
||||
list as ~~:agent~~ entry — isolates daemon→TUI communication.
|
||||
15. Full render: agent response text appears on rendered screen
|
||||
after LLM roundtrip — tests complete TUI→daemon→LLM→TUI pipeline.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Requires ~passepartout setup~ to have been run (skills in XDG data dir).
|
||||
- Phase 2 tests skip if required env vars are unset.
|
||||
- Phase 3 tests require tmux and Emacs installed.
|
||||
|
||||
* Prologue
|
||||
|
||||
Shared test harness: package, suite, helpers, and ~with-daemon~.
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t)
|
||||
(ql:quickload :usocket :silent t))
|
||||
|
||||
(defpackage :passepartout-integration-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:integration-suite))
|
||||
|
||||
(in-package :passepartout-integration-tests)
|
||||
|
||||
(fiveam:def-suite integration-suite :description "Integration tests across process boundaries")
|
||||
(fiveam:in-suite integration-suite)
|
||||
|
||||
(defvar *daemon-port* nil)
|
||||
|
||||
(defun find-free-port ()
|
||||
(let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t)))
|
||||
(unwind-protect (usocket:get-local-port socket)
|
||||
(usocket:socket-close socket))))
|
||||
|
||||
(defmacro with-daemon (() &body body)
|
||||
`(let ((*daemon-port* (find-free-port)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(passepartout:actuator-initialize)
|
||||
(passepartout:skill-initialize-all)
|
||||
(passepartout:start-daemon :port *daemon-port*)
|
||||
(sleep 2)
|
||||
,@body)
|
||||
(values)))
|
||||
|
||||
(defun daemon-connect ()
|
||||
(let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*))
|
||||
(stream (usocket:socket-stream sock)))
|
||||
(read-framed-message stream) ;; discard handshake
|
||||
(values stream sock)))
|
||||
|
||||
(defun daemon-send (stream msg)
|
||||
(write-string (frame-message msg) stream)
|
||||
(finish-output stream))
|
||||
|
||||
(defun daemon-recv (stream &key (timeout 5))
|
||||
(let ((deadline (+ (get-universal-time) timeout)))
|
||||
(loop
|
||||
(when (listen stream)
|
||||
(return (read-framed-message stream)))
|
||||
(when (> (get-universal-time) deadline) (return nil))
|
||||
(sleep 0.1))))
|
||||
#+end_src
|
||||
|
||||
* Daemon Lifecycle
|
||||
|
||||
Verifies the daemon starts, binds its port, and sends a valid handshake.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-daemon-starts
|
||||
"Contract 1: daemon binds port and sends valid handshake."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(is (open-stream-p stream))
|
||||
(usocket:socket-close sock))))
|
||||
#+end_src
|
||||
|
||||
* Pipeline End-to-End
|
||||
|
||||
Sends a ~:user-input~ event and verifies the pipeline produces a response.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-pipeline-user-input
|
||||
"Contract 2: :user-input traverses pipeline and produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test")))
|
||||
(let ((resp (daemon-recv stream :timeout 10)))
|
||||
(is (not (null resp)) "Expected a response")))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-pipeline-heartbeat
|
||||
"Contract 2: heartbeat signals do not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat)))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* Communication Protocol
|
||||
|
||||
Verifies framed TCP round-trip and malformed-input resilience.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-tcp-round-trip
|
||||
"Contract 3: framed health-check survives TCP round-trip."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream '(:TYPE :health-check))
|
||||
(let ((resp (daemon-recv stream :timeout 5)))
|
||||
(is (not (null resp)))
|
||||
(is (member (getf resp :type) '(:HEALTH-RESPONSE)))))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-daemon-survives-junk
|
||||
"Contract 3: daemon does not crash on junk input."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(write-string "ZZZZZZ" stream)
|
||||
(finish-output stream)
|
||||
(sleep 1)
|
||||
(usocket:socket-close sock))
|
||||
;; Connect again to verify daemon is still alive
|
||||
(multiple-value-bind (stream2 sock2) (daemon-connect)
|
||||
(is (open-stream-p stream2))
|
||||
(usocket:socket-close sock2))))
|
||||
#+end_src
|
||||
|
||||
* Skill Loader
|
||||
|
||||
Verifies the skill loader populates ~*skill-registry*~ after daemon start.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-skill-registry-populated
|
||||
"Contract 4: *skill-registry* is populated after daemon start."
|
||||
(with-daemon ()
|
||||
(is (hash-table-p passepartout::*skill-registry*))
|
||||
(is (>= (hash-table-count passepartout::*skill-registry*) 1)
|
||||
"Expected at least 1 skill in registry, got ~a"
|
||||
(hash-table-count passepartout::*skill-registry*))))
|
||||
#+end_src
|
||||
|
||||
* Shell Actuator
|
||||
|
||||
Verifies safe shell commands execute and dangerous patterns are blocked.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-shell-safe-echo
|
||||
"Contract 5: safe shell command does not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "echo hello")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-shell-dangerous-blocked
|
||||
"Contract 5: rm -rf / is blocked by the security dispatcher."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "rm -rf /")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* CLI Gateway
|
||||
|
||||
Verifies text input over TCP reaches the pipeline.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-cli-gateway-input
|
||||
"Contract 6: text via TCP produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :META (:SOURCE :CLI)
|
||||
:PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* Gateway Registry
|
||||
|
||||
Verifies the gateway registry function is available after daemon start.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-gateway-registry
|
||||
"Contract 7: gateway-registry-initialize is available."
|
||||
(with-daemon ()
|
||||
(is (fboundp 'gateway-registry-initialize))
|
||||
(gateway-registry-initialize)
|
||||
(pass)))
|
||||
#+end_src
|
||||
|
||||
* LLM Provider Cascade
|
||||
|
||||
Tests backend-cascade-call and provider-openai-request with real API
|
||||
credentials. Skipped silently if OPENROUTER_API_KEY is unset.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun has-api-key (env-var)
|
||||
"Returns T if env-var is set and non-empty."
|
||||
(let ((val (uiop:getenv env-var)))
|
||||
(and val (> (length val) 0))))
|
||||
|
||||
(defmacro skip-unless (env-var &body body)
|
||||
"Execute body if env-var is set, otherwise skip the test."
|
||||
`(if (has-api-key ,env-var)
|
||||
(progn ,@body)
|
||||
(progn
|
||||
(format t " [SKIP] ~a not set~%" ,env-var)
|
||||
(skip "~a not set" ,env-var))))
|
||||
|
||||
(fiveam:test test-provider-openai-request
|
||||
"Contract Phase2: provider-openai-request returns :success with valid API key."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((result (provider-openai-request "Say hello" "Be brief."
|
||||
:provider :openrouter
|
||||
:model "openrouter/auto")))
|
||||
(is (or (eq (getf result :status) :success)
|
||||
(eq (getf result :status) :error))
|
||||
"Expected :success or :error, got: ~a" result))))
|
||||
|
||||
(fiveam:test test-backend-cascade-real
|
||||
"Contract Phase2: backend-cascade-call returns string content with real provider."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((passepartout::*provider-cascade* '(:openrouter)))
|
||||
(let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief.")))
|
||||
(is (stringp result) "Expected string response, got: ~a" result)))))
|
||||
|
||||
(fiveam:test test-provider-cascade-parsing
|
||||
"Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends."
|
||||
(provider-cascade-initialize)
|
||||
(let ((cascade passepartout::*provider-cascade*))
|
||||
(is (listp cascade) "Cascade must be a list")
|
||||
(is (>= (length cascade) 1) "Cascade must have at least one entry")
|
||||
(dolist (entry cascade)
|
||||
(is (keywordp entry) "Entry ~s must be a keyword" entry)
|
||||
(let ((name (symbol-name entry)))
|
||||
(is (not (find #\" name)) "Entry ~s must not contain double-quote" entry)
|
||||
(is (not (find #\' name)) "Entry ~s must not contain single-quote" entry)))
|
||||
(is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade)
|
||||
"At least one cascade entry must match a registered backend")))
|
||||
#+end_src
|
||||
|
||||
* Messaging Link/Unlink
|
||||
|
||||
Verifies messaging-link stores a token in the vault, gateway-configured-p
|
||||
returns the correct status, and messaging-unlink removes it. No real
|
||||
API credentials needed — these are management functions.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-messaging-link-unlink
|
||||
"Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it."
|
||||
(with-daemon ()
|
||||
(messaging-link :test-platform :token "fake-token-123")
|
||||
(is (gateway-configured-p :test-platform)
|
||||
"Expected test-platform to be configured after linking")
|
||||
(messaging-unlink :test-platform)
|
||||
(is (not (gateway-configured-p :test-platform))
|
||||
"Expected test-platform to be unconfigured after unlinking")))
|
||||
|
||||
(fiveam:test test-gateway-configured-p-false
|
||||
"Contract Phase2: gateway-configured-p returns nil for unknown platform."
|
||||
(with-daemon ()
|
||||
(is (not (gateway-configured-p :nonexistent-platform-xyz)))))
|
||||
|
||||
(fiveam:test test-gateway-start-messaging
|
||||
"Contract Phase2: gateway registry initializes with expected platforms."
|
||||
(with-daemon ()
|
||||
(gateway-registry-initialize)
|
||||
(is (hash-table-p passepartout::*gateway-registry*))
|
||||
(is (>= (hash-table-count passepartout::*gateway-registry*) 1))))
|
||||
#+end_src
|
||||
|
||||
* TUI Integration Shell Script
|
||||
|
||||
Verifies the TUI end-to-end via tmux: input rendering, /eval, status bar,
|
||||
connection drop.
|
||||
|
||||
#+begin_src shell :tangle ../test/integration-tui.sh
|
||||
#!/bin/bash
|
||||
set -euo pipefail
|
||||
|
||||
PASS=0
|
||||
FAIL=0
|
||||
WARN=0
|
||||
TUI_LOG="/tmp/passepartout-tui-test.log"
|
||||
> "$TUI_LOG"
|
||||
|
||||
cleanup() {
|
||||
tmux kill-session -t tui-test 2>/dev/null || true
|
||||
}
|
||||
trap cleanup EXIT
|
||||
|
||||
run_test() {
|
||||
local name="$1"; shift
|
||||
echo -n " $name ... "
|
||||
if "$@" 2>/dev/null; then
|
||||
echo "PASS"
|
||||
PASS=$((PASS + 1))
|
||||
else
|
||||
echo "FAIL"
|
||||
FAIL=$((FAIL + 1))
|
||||
fi
|
||||
}
|
||||
|
||||
# ---- Setup ----
|
||||
echo "Starting TUI in tmux (daemon must already be running on port 9105)..."
|
||||
tmux new-session -d -s tui-test "passepartout tui 2>&1 | tee $TUI_LOG"
|
||||
for i in $(seq 1 20); do
|
||||
sleep 3
|
||||
if tmux capture-pane -t tui-test -p 2>/dev/null | grep -q 'Connected'; then
|
||||
echo " TUI ready after $((i*3))s"
|
||||
break
|
||||
fi
|
||||
if [ "$i" -eq 20 ]; then
|
||||
echo " WARNING: TUI did not render after 60s"
|
||||
fi
|
||||
done
|
||||
|
||||
# ---- Tests ----
|
||||
|
||||
test_cascade_parsing() {
|
||||
# Via /eval, check that *provider-cascade* contains clean keywords.
|
||||
tmux send-keys -t tui-test "/eval *provider-cascade*" Enter
|
||||
sleep 3
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -15 2>/dev/null)
|
||||
echo "$pane" | grep -q ':DEEPSEEK\|:OPENROUTER\|:OPENAI\|:ANTHROPIC\|:GROQ\|:GEMINI\|:NVIDIA'
|
||||
}
|
||||
|
||||
test_eval_command() {
|
||||
tmux send-keys -t tui-test "/eval (+ 1 2)" Enter
|
||||
sleep 3
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q '=> 3'
|
||||
}
|
||||
|
||||
test_status_bar() {
|
||||
tmux capture-pane -t tui-test -p -S -20 2>/dev/null | grep -q 'msgs:'
|
||||
}
|
||||
|
||||
# ---- Diagnostic: rendering pipeline isolation ----
|
||||
|
||||
test_add_msg_render() {
|
||||
# Stage A: can the TUI render an agent message at all?
|
||||
# Inject a message directly via /eval — bypasses daemon entirely.
|
||||
tmux send-keys -t tui-test "/eval (passepartout.gateway-tui:add-msg :agent \"RENDER-TEST-OK\")" Enter
|
||||
sleep 2
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q 'RENDER-TEST-OK'
|
||||
}
|
||||
|
||||
test_daemon_msg_roundtrip() {
|
||||
# Stage B: does the daemon's LLM response reach the TUI's message list?
|
||||
# Sends a message, waits, then checks via /eval that an :agent message exists.
|
||||
tmux send-keys -t tui-test "Say hello" Enter
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
while true; do
|
||||
local result
|
||||
result=$(tmux send-keys -t tui-test "/eval (loop for m in (passepartout.gateway-tui:st :messages) when (eq :agent (getf m :role)) return t)" Enter 2>/dev/null; sleep 3; tmux capture-pane -t tui-test -p -S -15 2>/dev/null | grep -o '=> [^ ]*' | tail -1)
|
||||
if echo "$result" | grep -q '=> T'; then
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no :agent msg in message list after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_agent_response_renders() {
|
||||
# Stage C: full end-to-end — LLM response appears on the rendered screen.
|
||||
# Must show actual response text, not a cascade failure.
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
tmux send-keys -t tui-test "Say hello in one word" Enter
|
||||
while true; do
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -60 2>/dev/null)
|
||||
if echo "$pane" | grep -qi 'hello\|hi there\|greeting\|hi[.!?]\|hey[.!?]'; then
|
||||
if echo "$pane" | grep -qi 'cascade.*fail\|exhausted\|neural cascade'; then
|
||||
echo "FAIL: agent responded with cascade failure, not LLM content" >&2
|
||||
return 1
|
||||
fi
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no agent response on screen after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_connection_drop() {
|
||||
sleep 1
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -qi 'connection.*lost\|ERROR.*Connection\|error.*connect' || true
|
||||
return 0
|
||||
}
|
||||
|
||||
run_test "cascade-parsing" test_cascade_parsing
|
||||
run_test "eval-command" test_eval_command
|
||||
run_test "status-bar" test_status_bar
|
||||
run_test "add-msg-render" test_add_msg_render
|
||||
run_test "daemon-msg-roundtrip" test_daemon_msg_roundtrip
|
||||
run_test "agent-response-renders" test_agent_response_renders
|
||||
run_test "connection-drop" test_connection_drop
|
||||
|
||||
# ---- Summary ----
|
||||
echo ""
|
||||
echo "===== $PASS passed, $FAIL failed, $WARN warnings ====="
|
||||
exit $(( FAIL > 0 ? 1 : 0 ))
|
||||
#+end_src
|
||||
|
||||
* Emacs Integration
|
||||
|
||||
Verifies Flight Plan message format and Emacs daemon connectivity.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-flight-plan-message-format
|
||||
"Contract Phase3: dispatcher-flight-plan-create returns valid message."
|
||||
(with-daemon ()
|
||||
(load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp"
|
||||
(user-homedir-pathname)))
|
||||
(let ((plan (dispatcher-flight-plan-create
|
||||
'(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart")))))
|
||||
(is (eq :REQUEST (getf plan :type)))
|
||||
(is (eq :emacs (getf plan :target)))
|
||||
(is (eq :insert-node (getf (getf plan :payload) :action)))
|
||||
(let ((attrs (getf (getf plan :payload) :attributes)))
|
||||
(is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE)))
|
||||
(is (string= "PLAN" (getf attrs :TODO)))
|
||||
(is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal))))))
|
||||
|
||||
(fiveam:test test-emacs-daemon-connect
|
||||
"Contract Phase3: Emacs daemon is reachable via emacsclient."
|
||||
(handler-case
|
||||
(let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)")
|
||||
:output :string
|
||||
:ignore-error-status t)))
|
||||
(is (search "3" result) "Expected '3' from emacsclient, got: ~a" result))
|
||||
(error (c)
|
||||
(skip "Emacs daemon not available: ~a" c)))))
|
||||
#+end_src
|
||||
345
org/token-economics.org
Normal file
345
org/token-economics.org
Normal file
@@ -0,0 +1,345 @@
|
||||
#+TITLE: Token Economics — caching, budget, and cost wiring
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :token-economics:budget:caching:
|
||||
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/token-economics.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
Token economics transforms the architecture's theoretical cost advantage into
|
||||
operational reality. Three subsystems work together:
|
||||
|
||||
1. ~Prompt prefix caching~ — the IDENTITY+TOOLS portion of the system prompt
|
||||
is static across calls (changes only on skill load or identity config).
|
||||
Hashing and caching it avoids retransmitting ~500-1500 tokens per call.
|
||||
|
||||
2. ~Incremental context assembly~ — the CONTEXT section is only regenerated
|
||||
when the foveal focus, scope, or memory state changes. Heartbeat ticks
|
||||
and tool-output feedback produce no context change, so assembly is skipped,
|
||||
saving ~200-800 tokens per heartbeat.
|
||||
|
||||
3. ~Token budget enforcement~ — when the total prompt exceeds
|
||||
~CONTEXT_MAX_TOKENS~ (default 16384), the system progressively trims
|
||||
less-essential sections (logs first, then standing mandates, then
|
||||
peripheral context).
|
||||
|
||||
These functions are called from ~think()~ via ~fboundp~ guards, keeping
|
||||
core-reason thin while enabling token economics as a hot-loadable skill.
|
||||
|
||||
Depends on: tokenizer.lisp, cost-tracker.lisp
|
||||
|
||||
** v0.8.0 — Context Usage for Sidebar
|
||||
|
||||
The sidebar's Context gauge needs a single integer: 0-100 representing
|
||||
how much of the token budget is consumed. ~context-usage-percentage~
|
||||
computes this from ~*context-cache*~'s stored token counts and
|
||||
~CONTEXT_MAX_TOKENS~ (or the model's context limit from ~tokenizer~).
|
||||
|
||||
The function is a thin wrapper (~8 lines): read the most recent context
|
||||
assembly's token count from ~*context-cache*~, divide by the budget,
|
||||
multiply by 100, clamp to [0, 100]. Called from ~core-act.org~'s ~:tui~
|
||||
actuator via ~fboundp~ guard. Degrades gracefully to nil when
|
||||
token-economics is not loaded.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (prompt-prefix-cached assistant-name identity-content feedback mandates-text tool-belt):
|
||||
Build the IDENTITY+TOOLS system prompt prefix. Uses ~sxhash~ on the inputs
|
||||
to detect changes. Returns the cached string when unchanged.
|
||||
2. (context-assemble-cached context sensor): Incrementally assemble awareness
|
||||
context. Skips assembly entirely for ~:heartbeat~ / ~:delegation~ sensors.
|
||||
Returns cached context when foveal-id, scope, and memory timestamp are
|
||||
unchanged. Falls back to ~[Awareness skill not loaded]~ when
|
||||
~context-assemble-global-awareness~ is not ~fboundp~.
|
||||
3. (enforce-token-budget prefix ctxt logs user prompt mandates &optional max):
|
||||
Enforce per-call token budget via progressive trimming:
|
||||
L1: truncate logs to last 5 lines
|
||||
L2: drop standing mandates
|
||||
L3: downgrade context to single-line summary
|
||||
Returns (values trimmed-prefix trimmed-ctxt trimmed-logs trimmed-user trimmed-mandates).
|
||||
4. (token-economics-initialize): zeroes the cache state at daemon boot.
|
||||
5. (context-usage-percentage): returns integer 0-100 representing
|
||||
current token budget consumption from ~*context-cache*~. Clamped.
|
||||
Returns nil when no context cache data is available. Consumed by
|
||||
the TUI actuator for the sidebar Context gauge (v0.8.0).
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Cache state
|
||||
#+begin_src lisp
|
||||
(defvar *prompt-prefix-cache* (cons nil "")
|
||||
"Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.")
|
||||
|
||||
(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered ""
|
||||
:identity-tokens 0 :tool-tokens 0 :context-tokens 0
|
||||
:log-tokens 0 :config-tokens 0 :time-tokens 0)
|
||||
"Context assembly cache: metadata + last rendered context string.")
|
||||
#+end_src
|
||||
|
||||
** Contract 1: prompt prefix caching
|
||||
#+begin_src lisp
|
||||
(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
|
||||
"Build the static IDENTITY+TOOLS system prompt prefix.
|
||||
Uses sxhash on inputs to detect changes; returns cached string on cache hit."
|
||||
(let* ((hash-key (sxhash (list assistant-name identity-content feedback mandates-text tool-belt)))
|
||||
(cached-hash (car *prompt-prefix-cache*))
|
||||
(cached-str (cdr *prompt-prefix-cache*)))
|
||||
(if (and cached-str (> (length cached-str) 0) (= hash-key cached-hash))
|
||||
cached-str
|
||||
(let ((new-prefix (format nil "IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a"
|
||||
assistant-name identity-content feedback
|
||||
(if (and mandates-text (> (length mandates-text) 0))
|
||||
(concatenate 'string (string #\Newline) mandates-text)
|
||||
"")
|
||||
tool-belt)))
|
||||
(setf (car *prompt-prefix-cache*) hash-key
|
||||
(cdr *prompt-prefix-cache*) new-prefix)
|
||||
new-prefix))))
|
||||
#+end_src
|
||||
|
||||
** Contract 2: incremental context assembly
|
||||
#+begin_src lisp
|
||||
(defun context-assemble-cached (context sensor)
|
||||
"Incrementally assemble awareness context.
|
||||
Skips assembly for heartbeat/delegation sensors.
|
||||
Uses cache when foveal, scope, and memory timestamp are unchanged."
|
||||
(when (member sensor '(:heartbeat :delegation))
|
||||
(return-from context-assemble-cached nil))
|
||||
(unless (fboundp 'context-assemble-global-awareness)
|
||||
(return-from context-assemble-cached "[Awareness skill not loaded]"))
|
||||
(let* ((foveal-id (getf context :foveal-focus))
|
||||
(scope (if (and (boundp '*scope-resolver*)
|
||||
*scope-resolver*)
|
||||
(funcall *scope-resolver*)
|
||||
nil))
|
||||
(mem-ts (hash-table-count *memory-store*))
|
||||
(cache-foveal (getf *context-cache* :foveal-id))
|
||||
(cache-scope (getf *context-cache* :scope))
|
||||
(cache-ts (getf *context-cache* :memory-timestamp))
|
||||
(cache-rendered (getf *context-cache* :rendered)))
|
||||
(if (and (equal foveal-id cache-foveal)
|
||||
(eq scope cache-scope)
|
||||
(= mem-ts cache-ts)
|
||||
cache-rendered
|
||||
(> (length cache-rendered) 0))
|
||||
cache-rendered
|
||||
(let ((rendered (funcall (symbol-function 'context-assemble-global-awareness))))
|
||||
(setf (getf *context-cache* :foveal-id) foveal-id
|
||||
(getf *context-cache* :scope) scope
|
||||
(getf *context-cache* :memory-timestamp) mem-ts
|
||||
(getf *context-cache* :rendered) rendered)
|
||||
rendered))))
|
||||
#+end_src
|
||||
|
||||
** Contract 3: token budget enforcement
|
||||
#+begin_src lisp
|
||||
(defun enforce-token-budget (prefix context-text logs-text user-prompt mandates-text
|
||||
&optional (max-tokens nil))
|
||||
"Enforce per-call token budget via progressive trimming.
|
||||
Returns (values prefix context-text logs-text user-prompt mandates-text)
|
||||
with trimmed sections."
|
||||
(let ((max (or max-tokens
|
||||
(ignore-errors
|
||||
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
|
||||
16384)))
|
||||
(labels ((ct (s) (if (fboundp 'count-tokens)
|
||||
(funcall (symbol-function 'count-tokens) s)
|
||||
(ceiling (length s) 4)))
|
||||
(total-tokens (p c l u m)
|
||||
(+ (ct p)
|
||||
(if c (ct c) 0)
|
||||
(ct l)
|
||||
(ct u)
|
||||
(if m (ct m) 0))))
|
||||
(let ((total (total-tokens prefix context-text logs-text user-prompt mandates-text)))
|
||||
(when (> total max)
|
||||
(log-message "TOKEN BUDGET: ~d tokens exceeds max ~d, trimming..."
|
||||
total max)
|
||||
;; L1: truncate logs to last 5 lines
|
||||
(let* ((log-lines (uiop:split-string logs-text :separator '(#\Newline)))
|
||||
(trimmed (if (> (length log-lines) 5)
|
||||
(format nil "~{~a~^~%~}" (last log-lines 5))
|
||||
logs-text)))
|
||||
(setf total (total-tokens prefix context-text trimmed user-prompt mandates-text)
|
||||
logs-text trimmed)
|
||||
(when (> total max)
|
||||
;; L2: drop standing mandates
|
||||
(setf total (total-tokens prefix context-text logs-text user-prompt nil)
|
||||
mandates-text nil)
|
||||
(when (> total max)
|
||||
;; L3: downgrade context to summary
|
||||
(let ((ctxt-lines (uiop:split-string (or context-text "") :separator '(#\Newline))))
|
||||
(setf context-text
|
||||
(format nil "[Context trimmed: ~d items]" (length ctxt-lines)))))))))
|
||||
(values prefix context-text logs-text user-prompt mandates-text))))
|
||||
#+end_src
|
||||
|
||||
** Contract 4: initialization
|
||||
#+begin_src lisp
|
||||
(defun token-economics-initialize ()
|
||||
"Zero cache state at daemon boot."
|
||||
(setf (car *prompt-prefix-cache*) nil
|
||||
(cdr *prompt-prefix-cache*) ""
|
||||
(getf *context-cache* :foveal-id) nil
|
||||
(getf *context-cache* :scope) nil
|
||||
(getf *context-cache* :memory-timestamp) 0
|
||||
(getf *context-cache* :rendered) ""))
|
||||
#+end_src
|
||||
|
||||
** Contract 5: context usage percentage (v0.8.0)
|
||||
#+begin_src lisp
|
||||
(defun context-usage-percentage ()
|
||||
"Returns integer 0-100: current token budget consumption.
|
||||
Returns nil when no context cache data is available."
|
||||
(let* ((limit (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
|
||||
16384))
|
||||
(tokens (+ (or (getf *context-cache* :identity-tokens) 0)
|
||||
(or (getf *context-cache* :tool-tokens) 0)
|
||||
(or (getf *context-cache* :context-tokens) 0)
|
||||
(or (getf *context-cache* :log-tokens) 0)
|
||||
(or (getf *context-cache* :config-tokens) 0)
|
||||
(or (getf *context-cache* :time-tokens) 0))))
|
||||
(if (> tokens 0)
|
||||
(min 100 (floor (* 100 tokens) limit))
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
#+end_src* v0.8.0 Tests — Context Usage
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(test test-context-usage-percentage
|
||||
"Contract 5: context-usage-percentage returns integer 0-100."
|
||||
;; Set up a cache with known token counts
|
||||
(let* ((ctx passepartout::*context-cache*)
|
||||
(limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
|
||||
16384)))
|
||||
(setf (getf ctx :identity-tokens) 1000
|
||||
(getf ctx :tool-tokens) 500
|
||||
(getf ctx :context-tokens) 2000
|
||||
(getf ctx :log-tokens) 800
|
||||
(getf ctx :config-tokens) 200
|
||||
(getf ctx :time-tokens) 100)
|
||||
(let ((pct (passepartout::context-usage-percentage)))
|
||||
(is (integerp pct))
|
||||
(is (<= 0 pct 100)))))
|
||||
|
||||
(test test-context-usage-percentage-empty-cache
|
||||
"Contract 5: context-usage-percentage returns nil with no cache data."
|
||||
(let ((saved-ctx (copy-list passepartout::*context-cache*)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (getf passepartout::*context-cache* :identity-tokens) nil
|
||||
(getf passepartout::*context-cache* :tool-tokens) nil
|
||||
(getf passepartout::*context-cache* :context-tokens) nil
|
||||
(getf passepartout::*context-cache* :log-tokens) nil
|
||||
(getf passepartout::*context-cache* :config-tokens) nil
|
||||
(getf passepartout::*context-cache* :time-tokens) nil)
|
||||
(is (null (passepartout::context-usage-percentage))))
|
||||
(setf passepartout::*context-cache* saved-ctx))))
|
||||
#+end_src
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user