Compare commits
17 Commits
7dad50910f
...
54ce3713cd
| Author | SHA1 | Date | |
|---|---|---|---|
| 54ce3713cd | |||
| cbbf409059 | |||
| 3c1ed77c85 | |||
| 9d7942dc1c | |||
| 8a7259c5c8 | |||
| d1951668cc | |||
| 1b4d147170 | |||
| 5ab54091c1 | |||
| 619407c6e6 | |||
| eb99847ccd | |||
| abfb7e5cf8 | |||
| 02e0c21f06 | |||
| 2e19db80ce | |||
| 31e53e675e | |||
| 3bb797ab9e | |||
| ef4ea1db1b | |||
| 908936d4d3 |
16
.env.example
16
.env.example
@@ -19,21 +19,25 @@ 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="openrouter,openai,anthropic,groq,gemini,deepseek"
|
||||
|
||||
# =============================================================================
|
||||
# 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)
|
||||
|
||||
@@ -49,7 +49,7 @@ See [[file:docs/USER_MANUAL.org][User Manual]] for the full guide.
|
||||
- [[file:org/core-memory.org][Memory]] — Single-address-space object store with Merkle-tree integrity and snapshot rollback
|
||||
- [[file:org/core-skills.org][Skill Engine]] — 20 hot-reloadable skills loaded at boot, each an independent Org file
|
||||
- [[file:org/gateway-tui.org][TUI]] — Croatoan-based terminal interface connected via framed TCP protocol
|
||||
- [[file:org/gateway-llm.org][LLM Routing]] — Cascade dispatch through multiple providers with tier-based model selection
|
||||
- [[file:org/system-model.org][LLM Dispatch]] — Central dispatch for model inference requests
|
||||
|
||||
* Project Documentation
|
||||
|
||||
|
||||
1
docs/.#ROADMAP.org
Symbolic link
1
docs/.#ROADMAP.org
Symbolic link
@@ -0,0 +1 @@
|
||||
user@amr.1092521:1777807168
|
||||
@@ -6,10 +6,10 @@
|
||||
|
||||
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 |
|
||||
| | 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.
|
||||
|
||||
@@ -19,27 +19,28 @@ The project is organized into ~org/~ (source of truth) and ~lisp/~ (generated by
|
||||
|
||||
** Core pipeline (loaded by ASDF, committed to git)
|
||||
|
||||
| File | Purpose |
|
||||
|------|---------|
|
||||
| ~org/core-defpackage.org~ | Package definition and export list |
|
||||
| ~org/core-skills.org~ | Skill engine: ~defskill~ macro, topological sorter, jailed loading |
|
||||
| ~org/core-communication.org~ | Framed TCP protocol, actuator registry, daemon server |
|
||||
| ~org/core-memory.org~ | ~memory-object~ struct, Merkle hashing, snapshots, persistence |
|
||||
| ~org/core-context.org~ | Foveal-peripheral rendering, context assembly for LLM |
|
||||
| ~org/core-loop-perceive.org~ | Stage 1: normalize raw signals into pipeline format |
|
||||
| ~org/core-loop-reason.org~ | Stage 2: LLM proposal + deterministic verification |
|
||||
| ~org/core-loop-act.org~ | Stage 3: dispatch approved actions to actuators |
|
||||
| ~org/core-loop.org~ | Orchestration: process-signal, heartbeat, main entry point |
|
||||
| ~org/system-diagnostics.org~ | Boot-time health check, doctor CLI |
|
||||
| File | Purpose |
|
||||
|------------------------------+--------------------------------------------------------------------|
|
||||
| ~org/core-defpackage.org~ | Package definition and export list |
|
||||
| ~org/core-skills.org~ | Skill engine: ~defskill~ macro, topological sorter, jailed loading |
|
||||
| ~org/core-communication.org~ | Framed TCP protocol, actuator registry, daemon server |
|
||||
| ~org/core-memory.org~ | ~memory-object~ struct, Merkle hashing, snapshots, persistence |
|
||||
| ~org/core-context.org~ | Foveal-peripheral rendering, context assembly for LLM |
|
||||
| ~org/core-loop-perceive.org~ | Stage 1: normalize raw signals into pipeline format |
|
||||
| ~org/core-loop-reason.org~ | Stage 2: LLM proposal + deterministic verification |
|
||||
| ~org/core-loop-act.org~ | Stage 3: dispatch approved actions to actuators |
|
||||
| ~org/core-loop.org~ | Orchestration: process-signal, heartbeat, main entry point |
|
||||
| ~org/system-diagnostics.org~ | Boot-time health check, doctor CLI |
|
||||
|
||||
** Skills (loaded at runtime by the skill engine)
|
||||
|
||||
| Category | Files | Purpose |
|
||||
|----------|-------|---------|
|
||||
| **gateway-** | ~gateway-cli~, ~gateway-llm~, ~gateway-manager~, ~gateway-provider~, ~gateway-tui~ | External communication channels |
|
||||
| **security-** | ~security-dispatcher~, ~security-policy~, ~security-permissions~, ~security-vault~, ~security-validator~ | Safety and authorization |
|
||||
| **programming-** | ~programming-lisp~, ~programming-org~, ~programming-standards~, ~programming-literate~, ~programming-repl~ | Lisp and Org tooling |
|
||||
| **system-** | ~system-config~, ~system-archivist~, ~system-self-improve~, ~system-memory~, ~system-actuator-shell~, ~system-event-orchestrator~ | Background services |
|
||||
| Category | Files | Purpose |
|
||||
|------------------+-----------------------------------------------------------------------------------------------------------------------------------+---------------------------------|
|
||||
| **gateway-** | ~gateway-cli~, ~gateway-messaging~, ~gateway-tui~ | External communication channels |
|
||||
| **system-model-** | ~system-model-provider~, ~system-model~, ~system-model-router~, ~system-model-embedding~, ~system-model-explorer~ | LLM infrastructure |
|
||||
| **security-** | ~security-dispatcher~, ~security-policy~, ~security-permissions~, ~security-vault~, ~security-validator~ | Safety and authorization |
|
||||
| **programming-** | ~programming-lisp~, ~programming-org~, ~programming-standards~, ~programming-literate~, ~programming-repl~ | Lisp and Org tooling |
|
||||
| **system-** | ~system-config~, ~system-archivist~, ~system-self-improve~, ~system-memory~, ~system-actuator-shell~, ~system-event-orchestrator~ | Background services |
|
||||
|
||||
* Pipeline Flow
|
||||
|
||||
@@ -63,14 +64,14 @@ A depth counter prevents infinite loops. If a signal's depth exceeds 10, it is s
|
||||
|
||||
* 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
|
||||
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
|
||||
|
||||
* Protocol Format
|
||||
* Communication protocol Format
|
||||
|
||||
All communication between the daemon and its gateways (TUI, CLI, Emacs) uses length-prefixed plists over TCP:
|
||||
|
||||
|
||||
@@ -42,24 +42,38 @@ Context window limits are largely a symptom of lazy architecture. The default ap
|
||||
|
||||
The unified memory argument is not that infinite context is free. It is that with proper architecture, effective infinite context is achievable without the synchronization and fragmentation costs of multi-agent systems.
|
||||
|
||||
* The Probabilistic-Deterministic Split
|
||||
* Org-Mode as Unified AST
|
||||
:PROPERTIES:
|
||||
:ID: design-probabilistic-deterministic
|
||||
:ID: design-org-unified-ast
|
||||
:END:
|
||||
|
||||
The architecture divides cognition into two fundamentally different reasoning systems. This is not arbitrary engineering but a structural response to a fundamental truth: probabilistic systems will hallucinate, and you cannot build reliable autonomy on an unreliable foundation.
|
||||
Passepartout makes a bet that most systems consider too expensive to place: that humans and machines should share the same file format. That bet is Org-mode.
|
||||
|
||||
An LLM is a statistical engine. It generates outputs based on patterns in training data. It is remarkable at translation, generation, pattern matching, and fuzzy reasoning. It can take messy human intent and produce structured queries. It can take structured results and produce natural language. It is, in the terminology of the system, the creative brain.
|
||||
Most systems separate human-readable notes from machine-readable data. The user writes Markdown. The system stores it, indexes it, searches it. But internally, the system maintains its own model - a database, an object store, a knowledge graph - that is disconnected from the Markdown. When the user dies or leaves, the Markdown survives but the model must be reconstructed.
|
||||
|
||||
But it cannot be trusted. Not because it is poorly designed or insufficiently trained, but because hallucination is a fundamental property of probabilistic inference. The model generates the most likely continuation, not the correct one. Given sufficient context, the most likely continuation is correct. Given novel context, it is often wrong in confident-sounding ways.
|
||||
Passepartout refuses this separation. The Org file is not a representation of the data. The Org file IS the data. The same text that the user reads and edits is what the system parses and operates on. org-element reads an Org buffer and returns a tree structure that is the direct Lisp representation of the file's content.
|
||||
|
||||
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.
|
||||
This has several profound implications.
|
||||
|
||||
The division of labor is architectural. The LLM handles the fuzzy interface between human language and structured representation. It translates what the user wants into what the system can reason about. The deterministic engine receives those structured representations and evaluates them against formal invariants. It decides whether to execute, not whether the translation was semantically plausible.
|
||||
First, there is no translation layer between human and machine. When the agent writes a skill, it writes Org text that is immediately readable by the human who owns the file. When the human writes a note, it is immediately accessible to the agent as a native data structure. The communication is not mediated by a schema or an import/export process.
|
||||
|
||||
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: the LLM never touches the file system, never executes a command, never modifies memory. It generates proposals. The deterministic engine evaluates and executes. The dangerous operations are never in the probabilistic path.
|
||||
Second, the format is genuinely readable by both parties, not just technically accessible. Org-mode's syntax is human-friendly: headlines begin with asterisks, properties live in drawers, tags are labels after colons. The human does not have to understand the full Org specification to read what the agent wrote. The agent does not have to handle edge cases in human notation.
|
||||
|
||||
The split also explains why the system gets safer over time without the LLM improving. The deterministic engine accumulates rules. The LLM proposes actions, the engine evaluates them against a growing rule set. Early versions block obvious dangers. Later versions block sophisticated attacks that were previously unknown. The safety grows logarithmically with the number of interactions, not linearly with model capability.
|
||||
Third, the format is stable across decades. Org-mode has been in active development since 2003. The files written today will be readable by Org-mode in 2040. There is no schema migration, no database upgrade, no vendor lock-in. The human's notes survive the system.
|
||||
|
||||
Fourth, the format is universally available. Org-mode is free software. The files are plain text. There is no proprietary format to decode, no application to purchase, no cloud service to access.
|
||||
|
||||
Fifth, the format is header-aware and sparse-tree capable. Org-mode's headline hierarchy is not just formatting - it is a semantic structure the system can query. The agent can retrieve only the relevant subtree under a heading, ignoring the rest of the file. This is fundamentally different from Markdown, where the entire file must be loaded or the retrieval logic must parse and filter at the string level.
|
||||
|
||||
Sparse tree retrieval is the key to efficient context management. When the agent needs information about the =openctl-db= function, it queries for the =openctl-db= subtree specifically. It receives exactly the code, documentation, and metadata under that heading - nothing more. The context stays lean not because the file was pre-split but because the retrieval is structural. In a Markdown system, the agent either loads the entire file (expensive, noisy) or relies on imprecise grep-like search (fragile, loses hierarchy). In Org-mode, retrieval is precise, hierarchical, and cheap. The heading boundary is the access boundary.
|
||||
|
||||
Sixth, Org-mode unifies what every other format fragments. A single Org file contains the headline hierarchy, prose documentation, source code blocks with live evaluation, tags for categorization, metadata in property drawers, TODO state for task management, timestamps and deadlines, and links to other nodes. Markdown cannot express TODO state without external tools. JSON cannot contain prose. YAML cannot embed runnable code. Each format serves one purpose; Org-mode serves all of them. When the agent reads a skill file, it reads documentation, code, dependencies, metadata, and task state in one parseable structure. When the human reads the same file, they see the same information rendered in a human-friendly form. No other format achieves this unification without maintaining parallel files or external databases.
|
||||
|
||||
Seventh, a skill lives in one Org file, not a directory. The standard pattern for a software project is a directory containing =README.md=, =package.json=, =src/main.py=, =src/utils.py=, =tests/test_main.py=, =scripts/deploy.sh=, and =config.yaml=. Each file type is isolated by convention: prose lives in README, code lives in src, tests in tests, configuration in config. This fragmentation means the skill is not a single object the system can reason about - it is a collection of files the system must assemble. Passepartout's skills violate this convention deliberately. Each skill is one Org file. The file contains the skill's documentation, the skill's code, the skill's metadata, the skill's TODO state, and the skill's dependencies on other skills. There is no directory to navigate, no external files to locate, no risk that the README describes behavior that the code does not implement. The skill is a single atomic unit: readable by human and machine, editable by both, versionable as one entity.
|
||||
|
||||
The unified format is what makes the memory architecture work. The agent's memory is not a database that the user cannot inspect. It is a folder of Org files that the user can read, edit, and understand. The agent manipulates these files directly, using the same tools the user would use. There is no hidden state, no shadow database, no model that differs from the source.
|
||||
|
||||
This is what "sovereignty" means in technical terms: the user owns the data in a format they can access, and the agent operates on the data in the same format they own.
|
||||
|
||||
* Homoiconicity as Foundation
|
||||
:PROPERTIES:
|
||||
@@ -104,59 +118,24 @@ Six decades later, neural networks have arrived at the problem from a different
|
||||
|
||||
Lisp's time may finally have come. Not as a replacement for neural networks, but as the governor that makes them safe - the symbolic engine that verifies what the neural engine proposes, the homoiconic substrate that allows the system to inspect, modify, and improve its own reasoning. The machine that was designed for AI in 1958 may be the exact machine needed for AI in 2026 and beyond.
|
||||
|
||||
* Org-Mode as Unified AST
|
||||
* The Probabilistic-Deterministic Split
|
||||
:PROPERTIES:
|
||||
:ID: design-org-unified-ast
|
||||
:ID: design-probabilistic-deterministic
|
||||
:END:
|
||||
|
||||
Passepartout makes a bet that most systems consider too expensive to place: that humans and machines should share the same file format. That bet is Org-mode.
|
||||
The architecture divides cognition into two fundamentally different reasoning systems. This is not arbitrary engineering but a structural response to a fundamental truth: probabilistic systems will hallucinate, and you cannot build reliable autonomy on an unreliable foundation.
|
||||
|
||||
Most systems separate human-readable notes from machine-readable data. The user writes Markdown. The system stores it, indexes it, searches it. But internally, the system maintains its own model - a database, an object store, a knowledge graph - that is disconnected from the Markdown. When the user dies or leaves, the Markdown survives but the model must be reconstructed.
|
||||
An LLM is a statistical engine. It generates outputs based on patterns in training data. It is remarkable at translation, generation, pattern matching, and fuzzy reasoning. It can take messy human intent and produce structured queries. It can take structured results and produce natural language. It is, in the terminology of the system, the creative brain.
|
||||
|
||||
Passepartout refuses this separation. The Org file is not a representation of the data. The Org file IS the data. The same text that the user reads and edits is what the system parses and operates on. org-element reads an Org buffer and returns a tree structure that is the direct Lisp representation of the file's content.
|
||||
But it cannot be trusted. Not because it is poorly designed or insufficiently trained, but because hallucination is a fundamental property of probabilistic inference. The model generates the most likely continuation, not the correct one. Given sufficient context, the most likely continuation is correct. Given novel context, it is often wrong in confident-sounding ways.
|
||||
|
||||
This has several profound implications.
|
||||
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.
|
||||
|
||||
First, there is no translation layer between human and machine. When the agent writes a skill, it writes Org text that is immediately readable by the human who owns the file. When the human writes a note, it is immediately accessible to the agent as a native data structure. The communication is not mediated by a schema or an import/export process.
|
||||
The division of labor is architectural. The LLM handles the fuzzy interface between human language and structured representation. It translates what the user wants into what the system can reason about. The deterministic engine receives those structured representations and evaluates them against formal invariants. It decides whether to execute, not whether the translation was semantically plausible.
|
||||
|
||||
Second, the format is genuinely readable by both parties, not just technically accessible. Org-mode's syntax is human-friendly: headlines begin with asterisks, properties live in drawers, tags are labels after colons. The human does not have to understand the full Org specification to read what the agent wrote. The agent does not have to handle edge cases in human notation.
|
||||
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: the LLM never touches the file system, never executes a command, never modifies memory. It generates proposals. The deterministic engine evaluates and executes. The dangerous operations are never in the probabilistic path.
|
||||
|
||||
Third, the format is stable across decades. Org-mode has been in active development since 2003. The files written today will be readable by Org-mode in 2040. There is no schema migration, no database upgrade, no vendor lock-in. The human's notes survive the system.
|
||||
|
||||
Fourth, the format is universally available. Org-mode is free software. The files are plain text. There is no proprietary format to decode, no application to purchase, no cloud service to access.
|
||||
|
||||
Fifth, the format is header-aware and sparse-tree capable. Org-mode's headline hierarchy is not just formatting - it is a semantic structure the system can query. The agent can retrieve only the relevant subtree under a heading, ignoring the rest of the file. This is fundamentally different from Markdown, where the entire file must be loaded or the retrieval logic must parse and filter at the string level.
|
||||
|
||||
Sparse tree retrieval is the key to efficient context management. When the agent needs information about the =openctl-db= function, it queries for the =openctl-db= subtree specifically. It receives exactly the code, documentation, and metadata under that heading - nothing more. The context stays lean not because the file was pre-split but because the retrieval is structural. In a Markdown system, the agent either loads the entire file (expensive, noisy) or relies on imprecise grep-like search (fragile, loses hierarchy). In Org-mode, retrieval is precise, hierarchical, and cheap. The heading boundary is the access boundary.
|
||||
|
||||
Sixth, Org-mode unifies what every other format fragments. A single Org file contains the headline hierarchy, prose documentation, source code blocks with live evaluation, tags for categorization, metadata in property drawers, TODO state for task management, timestamps and deadlines, and links to other nodes. Markdown cannot express TODO state without external tools. JSON cannot contain prose. YAML cannot embed runnable code. Each format serves one purpose; Org-mode serves all of them. When the agent reads a skill file, it reads documentation, code, dependencies, metadata, and task state in one parseable structure. When the human reads the same file, they see the same information rendered in a human-friendly form. No other format achieves this unification without maintaining parallel files or external databases.
|
||||
|
||||
Seventh, a skill lives in one Org file, not a directory. The standard pattern for a software project is a directory containing =README.md=, =package.json=, =src/main.py=, =src/utils.py=, =tests/test_main.py=, =scripts/deploy.sh=, and =config.yaml=. Each file type is isolated by convention: prose lives in README, code lives in src, tests in tests, configuration in config. This fragmentation means the skill is not a single object the system can reason about - it is a collection of files the system must assemble. Passepartout's skills violate this convention deliberately. Each skill is one Org file. The file contains the skill's documentation, the skill's code, the skill's metadata, the skill's TODO state, and the skill's dependencies on other skills. There is no directory to navigate, no external files to locate, no risk that the README describes behavior that the code does not implement. The skill is a single atomic unit: readable by human and machine, editable by both, versionable as one entity.
|
||||
|
||||
The unified format is what makes the memory architecture work. The agent's memory is not a database that the user cannot inspect. It is a folder of Org files that the user can read, edit, and understand. The agent manipulates these files directly, using the same tools the user would use. There is no hidden state, no shadow database, no model that differs from the source.
|
||||
|
||||
This is what "sovereignty" means in technical terms: the user owns the data in a format they can access, and the agent operates on the data in the same format they own.
|
||||
|
||||
* Literate Programming as Discipline
|
||||
:PROPERTIES:
|
||||
:ID: design-literate-programming
|
||||
:END:
|
||||
|
||||
The decision to use Org-mode as the source of truth for code, not just documentation, is not a ceremonial preference. It is a constraint mechanism that enforces better engineering habits at the cost of convenience.
|
||||
|
||||
The traditional development workflow is: write code, write comments, commit. The literate programming workflow is: write prose, write code, commit the Org. The order matters. The prose must come first not because of style guidelines but because the act of explaining what a function does before writing it forces clarity of thought that editing code directly does not.
|
||||
|
||||
When you must write a paragraph describing what a function does before you write the function, you discover the cases you have not considered. You find the edge conditions that are ambiguous. You realize that the function's name does not match its behavior, or that its behavior does not match your intent. The friction is not a bug - it is the mechanism by which thinking is enforced.
|
||||
|
||||
The one-function-per-block rule enforces granularity. A function that cannot be explained in a paragraph is a function that is doing too much. The block boundary is not aesthetic - it is architectural. It prevents the drift toward monolithic functions that accumulate responsibilities over time and become untestable, unmaintainable, and incomprehensible.
|
||||
|
||||
The tangle step enforces source-of-truth discipline. The .lisp file is generated from the Org file. This means the Org file cannot drift from the implementation. If the implementation changes, the Org must be updated to match. If the Org describes behavior that the implementation does not perform, the tangle produces code that does not match the Org description. Either way, inconsistency is visible and recoverable.
|
||||
|
||||
The evaluation gate enforces correctness. Every block can be evaluated independently in a running Lisp image. This means syntax errors are caught at authorship time, not at integration time. The function that compiles in isolation but fails in context is the function whose context dependencies were never made explicit. The evaluation gate forces those dependencies to surface.
|
||||
|
||||
Together, these constraints create a development experience that is slower in the small and faster in the large. Writing a new function takes longer because you must explain it. But debugging, maintaining, and extending the codebase is faster because every function has a human-readable explanation of its intent, every function is testable in isolation, and every function's source is always synchronized with its documentation.
|
||||
|
||||
The literate programming discipline is not about producing documentation. It is about producing code whose correctness has been verified by the act of explaining it.
|
||||
The split also explains why the system gets safer over time without the LLM improving. The deterministic engine accumulates rules. The LLM proposes actions, the engine evaluates them against a growing rule set. Early versions block obvious dangers. Later versions block sophisticated attacks that were previously unknown. The safety grows logarithmically with the number of interactions, not linearly with model capability.
|
||||
|
||||
* The Dispatcher as Learning System
|
||||
:PROPERTIES:
|
||||
@@ -198,6 +177,27 @@ Third, the REPL is a shared substrate. When the agent evaluates code, that code
|
||||
|
||||
This is why the REPL becomes more important as the system matures. In early versions, it is a development tool. In v0.6.0 and beyond, it becomes a cognitive tool: the agent explores hypotheses by evaluating them, verifies the output of sub-agents by inspecting live state, and tests modifications before committing them to the knowledge graph.
|
||||
|
||||
* Literate Programming as Discipline
|
||||
:PROPERTIES:
|
||||
:ID: design-literate-programming
|
||||
:END:
|
||||
|
||||
The decision to use Org-mode as the source of truth for code, not just documentation, is not a ceremonial preference. It is a constraint mechanism that enforces better engineering habits at the cost of convenience.
|
||||
|
||||
The traditional development workflow is: write code, write comments, commit. The literate programming workflow is: write prose, write code, commit the Org. The order matters. The prose must come first not because of style guidelines but because the act of explaining what a function does before writing it forces clarity of thought that editing code directly does not.
|
||||
|
||||
When you must write a paragraph describing what a function does before you write the function, you discover the cases you have not considered. You find the edge conditions that are ambiguous. You realize that the function's name does not match its behavior, or that its behavior does not match your intent. The friction is not a bug - it is the mechanism by which thinking is enforced.
|
||||
|
||||
The one-function-per-block rule enforces granularity. A function that cannot be explained in a paragraph is a function that is doing too much. The block boundary is not aesthetic - it is architectural. It prevents the drift toward monolithic functions that accumulate responsibilities over time and become untestable, unmaintainable, and incomprehensible.
|
||||
|
||||
The tangle step enforces source-of-truth discipline. The .lisp file is generated from the Org file. This means the Org file cannot drift from the implementation. If the implementation changes, the Org must be updated to match. If the Org describes behavior that the implementation does not perform, the tangle produces code that does not match the Org description. Either way, inconsistency is visible and recoverable.
|
||||
|
||||
The evaluation gate enforces correctness. Every block can be evaluated independently in a running Lisp image. This means syntax errors are caught at authorship time, not at integration time. The function that compiles in isolation but fails in context is the function whose context dependencies were never made explicit. The evaluation gate forces those dependencies to surface.
|
||||
|
||||
Together, these constraints create a development experience that is slower in the small and faster in the large. Writing a new function takes longer because you must explain it. But debugging, maintaining, and extending the codebase is faster because every function has a human-readable explanation of its intent, every function is testable in isolation, and every function's source is always synchronized with its documentation.
|
||||
|
||||
The literate programming discipline is not about producing documentation. It is about producing code whose correctness has been verified by the act of explaining it.
|
||||
|
||||
* The Evaluation Harness
|
||||
:PROPERTIES:
|
||||
:ID: design-evaluation-harness
|
||||
|
||||
@@ -211,7 +211,7 @@ CLOSED: [2026-05-03 Sun 10:42]
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=vault-get-secret= and =vault-set-secret= are exported from =core-defpackage=
|
||||
and called from =gateway-manager.org= (lines 36, 86, 180) but never defined.
|
||||
and called from =gateway-messaging.org= (lines 36, 86, 180) but never defined.
|
||||
=gateway-link= crashes at runtime. Add one-line wrappers in =security-vault.org=
|
||||
that delegate to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
|
||||
@@ -338,6 +338,15 @@ for targeted retrieval of specific function docs or test blocks by heading name.
|
||||
|
||||
***** DONE P3: Variable name drift normalization (out of scope for now) :backfill:
|
||||
CLOSED: [2026-05-03 Sun 11:50]
|
||||
|
||||
***** TODO P4: Eliminate STYLE-WARNINGs from setup output :cosmetic:
|
||||
SBCL emits ~25 STYLE-WARNINGs at boot due to forward references (function
|
||||
called before its =defun= appears in the file). Actual bugs (C/T, handler-case,
|
||||
bare =return=) are already fixed. Remaining warnings fall into two categories:
|
||||
1. Same-file forward references (reorder =defun=s to fix).
|
||||
2. Cross-skill references (inherent to skill architecture; suppress or accept).
|
||||
Reordering is mechanical but tedious — grep each file's =defun= list, compute
|
||||
topological order, move definitions down. Do not change function bodies.
|
||||
:PROPERTIES:
|
||||
:ID: id-name-normalization
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
|
||||
@@ -113,6 +113,10 @@
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Backward-compatibility alias for protocol-schema-validate."
|
||||
(protocol-schema-validate msg))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
|
||||
@@ -243,5 +243,7 @@
|
||||
(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)))
|
||||
|
||||
@@ -39,12 +39,18 @@
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
;; 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'" target))))))
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" actual-target))))))
|
||||
|
||||
(defun action-system-execute (action context)
|
||||
"Execute internal harness commands."
|
||||
|
||||
@@ -1,5 +1,12 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(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))
|
||||
|
||||
(defvar *backend-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *provider-cascade* nil)
|
||||
@@ -15,30 +22,33 @@
|
||||
(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 *backend-registry*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model-val (when *model-selector*
|
||||
(funcall *model-selector* backend context))))
|
||||
(if (eq model-val :skip)
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)
|
||||
(let* ((model (if model-val model-val nil))
|
||||
(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
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message)))))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
|
||||
|
||||
(defun markdown-strip (text)
|
||||
(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 (or (gethash backend *backend-registry*)
|
||||
(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
|
||||
(if (and model (not skip))
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt)))))
|
||||
(when skip
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
||||
(cond ((and (listp r) (eq (getf r :status) :success))
|
||||
(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))))))))))(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
@@ -84,40 +94,52 @@
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (markdown-strip thought)))
|
||||
(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 (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(plist-keywords-normalize parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(let ((normalized (plist-keywords-normalize parsed)))
|
||||
;; Ensure explanation is present in the payload for policy gate
|
||||
(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 cognitive-verify (proposed-action context)
|
||||
"Runs all registered deterministic gates against the proposed action.
|
||||
Returns either a rejection plist (for :LOG or :EVENT errors) or the
|
||||
modified action (for approval-required or pass)."
|
||||
"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))
|
||||
(approval-action nil)
|
||||
(gates nil))
|
||||
;; Collect gates sorted by priority (highest first)
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(let ((gate (skill-deterministic-fn skill)))
|
||||
(when gate
|
||||
(let ((result (funcall gate current-action context)))
|
||||
(cond
|
||||
;; Approval-required: remember it and continue checking
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
;; Hard rejection: return immediately
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
;; Normal: update action
|
||||
(t (setf current-action result))))))))
|
||||
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
|
||||
*skill-registry*)
|
||||
(setf gates (sort gates #'> :key #'car))
|
||||
(dolist (gate-pair gates)
|
||||
(let ((result (funcall (cdr gate-pair) current-action context)))
|
||||
(cond
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
((and (listp result) result)
|
||||
(setf current-action result)))))
|
||||
(if approval-needed
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required
|
||||
|
||||
@@ -117,6 +117,12 @@
|
||||
(actuator-initialize)
|
||||
(skill-initialize-all)
|
||||
|
||||
;; Check for configured LLM providers
|
||||
(when (zerop (hash-table-count *probabilistic-backends*))
|
||||
(log-message "WELCOME: No LLM providers configured. Run 'passepartout tui' and press F2 to set up.")
|
||||
(log-message "WELCOME: Supported providers: openrouter, openai, anthropic, groq, gemini, deepseek, nvidia")
|
||||
(log-message "WELCOME: For free tier, start with OPENROUTER_API_KEY at https://openrouter.ai"))
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
(diagnostics-startup-run)
|
||||
|
||||
@@ -139,6 +145,11 @@
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
|
||||
(defun providers-configured-p ()
|
||||
"Returns T if at least one probabilistic backend is registered."
|
||||
(and (boundp '*probabilistic-backends*)
|
||||
(> (hash-table-count *probabilistic-backends*) 0)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
|
||||
@@ -97,7 +97,13 @@
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest")
|
||||
(string= n "security-dispatcher")
|
||||
(string= n "system-embedding-gateway"))))
|
||||
(string= n "system-model-router")
|
||||
(string= n "system-model-embedding")
|
||||
(string= n "system-model-explorer")
|
||||
(string= n "gateway-tui")
|
||||
(string= n "gateway-tui-model")
|
||||
(string= n "gateway-tui-view")
|
||||
(string= n "gateway-tui-main"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
@@ -206,26 +212,21 @@
|
||||
(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))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(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 "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" 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))))))
|
||||
(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)
|
||||
@@ -251,26 +252,21 @@
|
||||
(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* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(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 "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" 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))))))
|
||||
(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)
|
||||
|
||||
@@ -1,43 +0,0 @@
|
||||
(defun gateway-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :passepartout-gateway-llm
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(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 Gateway skill")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-llm-gateway-timeout
|
||||
"Tier 2 Chaos: Verify that LLM Gateway handles connection failures gracefully."
|
||||
(let ((old-host (uiop:getenv "OLLAMA_HOST")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "OLLAMA_HOST") "localhost:1")
|
||||
(let ((fn (or (find-symbol "GATEWAY-LLM-REQUEST" :passepartout.gateway-llm)
|
||||
(find-symbol "GATEWAY-LLM-REQUEST" :passepartout))))
|
||||
(if fn
|
||||
(let ((result (funcall fn :prompt "hello" :provider :ollama)))
|
||||
(fiveam:is (eq (getf result :status) :error))
|
||||
(fiveam:is (uiop:string-prefix-p "Ollama Failure" (getf result :message))))
|
||||
(fiveam:fail "Could not find EXECUTE-LLM-REQUEST symbol"))))
|
||||
(if old-host
|
||||
(setf (uiop:getenv "OLLAMA_HOST") old-host)
|
||||
(sb-posix:unsetenv "OLLAMA_HOST")))))
|
||||
@@ -1,8 +1,8 @@
|
||||
(defvar *gateway-configs* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:token :thread :interval :enabled)")
|
||||
"Maps platform name to plist (:token :thread :interval :enabled)")
|
||||
|
||||
(defvar *gateway-registry* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
|
||||
"Maps platform name to plist (:poll-fn :send-fn :default-interval)")
|
||||
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
@@ -25,14 +25,14 @@
|
||||
(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))))))
|
||||
(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."
|
||||
@@ -43,7 +43,6 @@
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(log-message "TELEGRAM: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
@@ -62,7 +61,7 @@
|
||||
(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)))
|
||||
(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)))
|
||||
@@ -70,13 +69,13 @@
|
||||
(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))))))))
|
||||
(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)
|
||||
@@ -88,7 +87,6 @@
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(log-message "SIGNAL: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
|
||||
:output :string :error-output :string)
|
||||
@@ -117,7 +115,7 @@
|
||||
(getf config :thread)
|
||||
(bt:thread-alive-p (getf config :thread)))))
|
||||
|
||||
(defun gateway-link (platform token)
|
||||
(defun messaging-link (platform token)
|
||||
"Links a platform with a token and starts polling."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(unless (gethash platform-lc *gateway-registry*)
|
||||
@@ -125,7 +123,7 @@
|
||||
platform (loop for k being the hash-keys of *gateway-registry* collect k)))
|
||||
(when (or (null token) (zerop (length token)))
|
||||
(error "Token cannot be empty"))
|
||||
(log-message "GATEWAY: Linking to ~a..." platform-lc)
|
||||
(log-message "MESSAGING: Linking to ~a..." platform-lc)
|
||||
(gateway-unlink platform-lc)
|
||||
(let* ((registry-entry (gethash platform-lc *gateway-registry*))
|
||||
(interval (or (getf registry-entry :default-interval) 5)))
|
||||
@@ -133,16 +131,16 @@
|
||||
(list :token token :interval interval :enabled t))
|
||||
(vault-set-secret (intern (string-upcase platform-lc) :keyword) token)
|
||||
(gateway-start platform-lc)
|
||||
(log-message "GATEWAY: Successfully linked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Successfully linked ~a" platform-lc)
|
||||
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
|
||||
t)))
|
||||
|
||||
(defun gateway-unlink (platform)
|
||||
(defun messaging-unlink (platform)
|
||||
"Unlinks a platform and stops its polling thread."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(gateway-stop platform-lc)
|
||||
(remhash platform-lc *gateway-configs*)
|
||||
(log-message "GATEWAY: Unlinked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Unlinked ~a" platform-lc)
|
||||
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
|
||||
t))
|
||||
|
||||
@@ -162,7 +160,7 @@
|
||||
(funcall poll-fn))
|
||||
(sleep interval)))
|
||||
:name (format nil "passepartout-~a-gateway" platform-lc)))
|
||||
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
|
||||
(log-message "MESSAGING: Started ~a polling (interval: ~as)" platform-lc interval))))))))
|
||||
|
||||
(defun gateway-stop (platform)
|
||||
"Stops the polling thread for a gateway."
|
||||
@@ -170,11 +168,11 @@
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :thread))
|
||||
(when (bt:thread-alive-p (getf config :thread))
|
||||
(log-message "GATEWAY: Stopping ~a polling thread" platform-lc)
|
||||
(log-message "MESSAGING: Stopping ~a polling thread" platform-lc)
|
||||
(bt:destroy-thread (getf config :thread))))
|
||||
(setf (getf config :thread) nil))))
|
||||
|
||||
(defun gateway-list ()
|
||||
(defun messaging-list ()
|
||||
"Returns a list of all gateways with their status."
|
||||
(loop for platform being the hash-keys of *gateway-registry*
|
||||
collect (let ((configured (gateway-configured-p platform))
|
||||
@@ -183,11 +181,11 @@
|
||||
:configured configured
|
||||
:active active))))
|
||||
|
||||
(defun gateway-list-print ()
|
||||
(defun messaging-list-print ()
|
||||
"Prints a formatted table of gateways."
|
||||
(format t "~%")
|
||||
(format t " ~20@A ~12@A ~10@A~%" "PLATFORM" "CONFIGURED" "STATUS")
|
||||
(dolist (gw (gateway-list))
|
||||
(dolist (gw (messaging-list))
|
||||
(format t " ~20@A ~12@A ~10@A~%"
|
||||
(getf gw :platform)
|
||||
(if (getf gw :configured) "yes" "no")
|
||||
@@ -208,7 +206,7 @@
|
||||
(register-actuator :telegram #'telegram-send)
|
||||
(register-actuator :signal #'signal-send)
|
||||
|
||||
(defskill :passepartout-gateway-manager
|
||||
(defskill :passepartout-gateway-messaging
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
165
lisp/gateway-tui-main.lisp
Normal file
165
lisp/gateway-tui-main.lisp
Normal file
@@ -0,0 +1,165 @@
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun on-key (&rest args)
|
||||
(let ((ch (car args)))
|
||||
(cond
|
||||
;; Enter
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
|
||||
(when (> (length text) 0)
|
||||
(push text (st :input-history))
|
||||
(setf (st :input-hpos) 0)
|
||||
(setf (st :scroll-offset) 0)
|
||||
(cond
|
||||
;; /eval command
|
||||
((and (>= (length text) 6)
|
||||
(string-equal (subseq text 0 6) "/eval "))
|
||||
(handler-case
|
||||
(let* ((*read-eval* t)
|
||||
(*package* (find-package :passepartout.gateway-tui))
|
||||
(r (eval (read-from-string (subseq text 6)))))
|
||||
(add-msg :system (format nil "=> ~s" r)))
|
||||
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
|
||||
;; Normal message
|
||||
(t
|
||||
(add-msg :user text)
|
||||
(send-daemon (list :type :event
|
||||
:payload (list :sensor :user-input :text text)))))
|
||||
(setf (st :input-buffer) nil)
|
||||
(setf (st :dirty) (list t t t)))))
|
||||
;; Backspace
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(when (st :input-buffer) (pop (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
;; Up arrow
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let* ((h (st :input-history)) (p (st :input-hpos)))
|
||||
(when (and h (< p (1- (length h))))
|
||||
(incf (st :input-hpos))
|
||||
(setf (st :input-buffer)
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list)))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; Down arrow
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(when (> (st :input-hpos) 0)
|
||||
(decf (st :input-hpos))
|
||||
(let ((h (st :input-history)))
|
||||
(setf (st :input-buffer)
|
||||
(if (and h (< (st :input-hpos) (length h)))
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list))
|
||||
nil))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; PageUp
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(incf (st :scroll-offset) 5)
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; PageDown
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; Printable
|
||||
(t
|
||||
(let ((chr (typecase ch
|
||||
(character ch)
|
||||
(integer (code-char ch))
|
||||
(t nil))))
|
||||
(when (and chr (graphic-char-p chr))
|
||||
(push chr (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t))))))))
|
||||
|
||||
(defun on-daemon-msg (msg)
|
||||
(let* ((payload (getf msg :payload))
|
||||
(text (getf payload :text))
|
||||
(action (getf payload :action)))
|
||||
(cond
|
||||
(text (add-msg :agent text))
|
||||
((eq action :handshake)
|
||||
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
|
||||
(t (add-msg :agent (format nil "~a" msg))))))
|
||||
|
||||
(defun send-daemon (msg)
|
||||
(let ((s (st :stream)))
|
||||
(when (and s (open-stream-p s))
|
||||
(handler-case
|
||||
(progn
|
||||
(format s "~a" (frame-message msg))
|
||||
(finish-output s))
|
||||
(error (c) (log-message "TUI-SEND: ~a" c))))))
|
||||
|
||||
(defun recv-daemon (s)
|
||||
(handler-case
|
||||
(let* ((hdr (make-string 6)) (n 0))
|
||||
(loop while (< n 6)
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon 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 s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char buf i) ch)))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string buf)))))
|
||||
(error (c) (log-message "TUI-RECV: ~a" c) nil)))
|
||||
|
||||
(defun reader-loop (s)
|
||||
(loop while (and (st :running) (open-stream-p s))
|
||||
do (let ((msg (recv-daemon s)))
|
||||
(when msg (queue-event (list :type :daemon :payload msg))))))
|
||||
|
||||
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||
(handler-case
|
||||
(let ((s (usocket:socket-connect host port :element-type 'character)))
|
||||
(setf (st :stream) (usocket:socket-stream s) (st :connected) t)
|
||||
(bt:make-thread (lambda () (reader-loop (st :stream))) :name "tui-reader")
|
||||
(add-msg :system "* Connected *")
|
||||
t)
|
||||
(error (c)
|
||||
(add-msg :system (format nil "* Connection failed: ~a *" c))
|
||||
nil)))
|
||||
|
||||
(defun disconnect-daemon ()
|
||||
(when (st :stream)
|
||||
(ignore-errors (close (st :stream)))
|
||||
(setf (st :stream) nil (st :connected) nil)
|
||||
(add-msg :system "* Disconnected *")))
|
||||
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
|
||||
(ch (- h 5))
|
||||
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(st :dirty) (list t t t))
|
||||
(connect-daemon)
|
||||
(when (> swank-port 0)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload :swank :silent t)
|
||||
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
||||
:port swank-port :dont-close t)
|
||||
(add-msg :system
|
||||
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
|
||||
(error ()
|
||||
(add-msg :system "* Swank unavailable *"))))
|
||||
(loop while (st :running) do
|
||||
(dolist (ev (drain-queue))
|
||||
(when (eq (getf ev :type) :daemon)
|
||||
(on-daemon-msg (getf ev :payload))))
|
||||
(let ((ch (get-char iw)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(on-key ch)))
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon))))
|
||||
38
lisp/gateway-tui-model.lisp
Normal file
38
lisp/gateway-tui-model.lisp
Normal file
@@ -0,0 +1,38 @@
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
|
||||
(:export :tui-main :st :add-msg :now :input-string
|
||||
:queue-event :drain-queue :init-state
|
||||
:view-status :view-chat :view-input :redraw))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *state* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
||||
|
||||
(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-buffer nil :input-history nil :input-hpos 0
|
||||
:messages nil :scroll-offset 0 :dirty (list nil nil nil))))
|
||||
|
||||
(defun now ()
|
||||
(multiple-value-bind (h m) (get-decoded-time)
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun input-string ()
|
||||
(coerce (reverse (st :input-buffer)) 'string))
|
||||
|
||||
(defun add-msg (role content)
|
||||
(push (list :role role :content content :time (now)) (st :messages))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
|
||||
(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)))
|
||||
59
lisp/gateway-tui-view.lisp
Normal file
59
lisp/gateway-tui-view.lisp
Normal file
@@ -0,0 +1,59 @@
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun view-status (win)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(add-string win
|
||||
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a"
|
||||
(if (st :connected) "● Connected" "○ Disconnected")
|
||||
(string-upcase (string (st :mode)))
|
||||
(length (st :messages))
|
||||
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
|
||||
:y 1 :x 1 :fgcolor (if (st :connected) :green :red))
|
||||
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
|
||||
(refresh win))
|
||||
|
||||
(defun view-chat (win h)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 78))
|
||||
(msgs (reverse (st :messages)))
|
||||
(max-lines (- h 2))
|
||||
(total (length msgs))
|
||||
(start (max 0 (- total max-lines (st :scroll-offset))))
|
||||
(y 1))
|
||||
(loop for i from start below total
|
||||
while (< y (1- h))
|
||||
do (let ((msg (nth i msgs)))
|
||||
(let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(time (or (getf msg :time) ""))
|
||||
(label (case role
|
||||
(:user (format nil "⬆ [~a] ~a" time content))
|
||||
(:agent (format nil "⬇ [~a] ~a" time content))
|
||||
(:system (format nil " [~a] ~a" time content))
|
||||
(t (format nil " [~a] ~a" time content))))
|
||||
(color (case role
|
||||
(:user :green)
|
||||
(:agent :white)
|
||||
(:system :yellow)
|
||||
(t :white))))
|
||||
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
|
||||
(incf y)))))
|
||||
(refresh win))
|
||||
|
||||
(defun view-input (win)
|
||||
(let* ((text (input-string))
|
||||
(w (or (width win) 78))
|
||||
(clip (min (length text) (1- w))))
|
||||
(clear win)
|
||||
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
|
||||
(setf (cursor-position win) (list 0 clip)))
|
||||
(refresh win))
|
||||
|
||||
(defun redraw (sw cw ch iw)
|
||||
(destructuring-bind (sd cd id) (st :dirty)
|
||||
(when sd (view-status sw))
|
||||
(when cd (view-chat cw ch))
|
||||
(when id (view-input iw))
|
||||
(setf (st :dirty) (list nil nil nil))))
|
||||
@@ -1,263 +0,0 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *daemon-host* "localhost")
|
||||
|
||||
(defvar *daemon-port* 9105)
|
||||
|
||||
(defvar *socket* nil)
|
||||
|
||||
(defvar *stream* nil)
|
||||
|
||||
(defvar *chat-history* nil)
|
||||
|
||||
(defvar *chat-scroll-pos* 0)
|
||||
|
||||
(defvar *input-buffer* nil)
|
||||
|
||||
(defvar *input-history* nil)
|
||||
(defvar *input-history-pos* nil)
|
||||
|
||||
(defvar *is-running* t)
|
||||
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
|
||||
(defvar *incoming* nil)
|
||||
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/passepartout-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 message-queue-push (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming* (append *incoming* (list msg)))))
|
||||
|
||||
(defun message-queue-drain ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming*))
|
||||
(setf *incoming* nil)
|
||||
msgs)))
|
||||
|
||||
(defun timestamp-now ()
|
||||
"Return a short HH:MM timestamp string."
|
||||
(multiple-value-bind (s m h) (decode-universal-time (get-universal-time))
|
||||
(declare (ignore s))
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun input-render (win)
|
||||
(clear win)
|
||||
(let ((text (coerce (reverse *input-buffer*) 'string)))
|
||||
(if (> (length text) 0)
|
||||
(add-string win (format nil "▶ ~a" text) :y 0 :x 1)
|
||||
(add-string win "▶ " :y 0 :x 1)))
|
||||
(refresh win))
|
||||
|
||||
(defun chat-render (win h &optional (offset 0))
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history *chat-history*)
|
||||
(len (length history))
|
||||
(start (max 0 (- len view-height offset)))
|
||||
(end (min len (+ start view-height))))
|
||||
(loop for i from start below end
|
||||
for msg in (subseq history start end)
|
||||
for row from 1
|
||||
do (add-string win (format nil "│ ~a" msg) :y row :x 2)))
|
||||
(refresh win)))
|
||||
|
||||
(defun status-render (win)
|
||||
(when win
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((status (if (and *stream* (open-stream-p *stream*)) "●" "○"))
|
||||
(msgs (length *chat-history*))
|
||||
(scroll-indicator (if (> *chat-scroll-pos* 0)
|
||||
(format nil " ↑~a" *chat-scroll-pos*)
|
||||
""))
|
||||
(time (timestamp-now)))
|
||||
(add-string win (format nil "│ ~a PASSEPARTOUT [~a msgs]~a ~a"
|
||||
status msgs scroll-indicator time)
|
||||
:y 1 :x 2)))
|
||||
(refresh win))
|
||||
|
||||
(defun input-backspace ()
|
||||
(pop *input-buffer*))
|
||||
|
||||
(defun input-history-push (cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(setf *input-history* (cons cmd *input-history*))
|
||||
(setf *input-history-pos* nil)))
|
||||
|
||||
(defun input-history-nav (direction)
|
||||
(let ((len (length *input-history*)))
|
||||
(if (= len 0)
|
||||
nil
|
||||
(case direction
|
||||
(:up
|
||||
(let ((pos (if *input-history-pos*
|
||||
(min (1+ *input-history-pos*) (1- len))
|
||||
0)))
|
||||
(setf *input-history-pos* pos)
|
||||
(nth pos *input-history*)))
|
||||
(:down
|
||||
(if *input-history-pos*
|
||||
(if (= *input-history-pos* 0)
|
||||
(progn (setf *input-history-pos* nil) nil)
|
||||
(let ((pos (1- *input-history-pos*)))
|
||||
(setf *input-history-pos* pos)
|
||||
(nth pos *input-history*)))
|
||||
nil))))))
|
||||
|
||||
(defun input-submit (stream)
|
||||
(let ((cmd (coerce (reverse *input-buffer*) 'string)))
|
||||
(setf *input-buffer* nil)
|
||||
(setf *input-history-pos* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(input-history-push cmd)
|
||||
(let* ((ts (timestamp-now))
|
||||
(display (format nil "⬆ [~a] ~a" ts cmd)))
|
||||
(push display *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) (setf *chat-scroll-pos* 0))))
|
||||
|
||||
(defun reader-start (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))
|
||||
(payload (getf msg :payload))
|
||||
(ts (timestamp-now)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(message-queue-push (format nil "⬇ [~a] * Connected *" ts)))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(message-queue-push (format nil "⬇ [~a] ~a" ts text)))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(message-queue-push "⬇ [--:--] ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "passepartout-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))
|
||||
(status-h 3)
|
||||
(input-h 1)
|
||||
(chat-h (- h status-h input-h 1))
|
||||
(status-win (make-instance 'window :height status-h :width (- w 2) :y 0 :x 1))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y status-h :x 1))
|
||||
(input-win (make-instance 'window :height input-h :width (- w 2) :y (- h input-h 1) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(setf (function-keys-enabled-p input-win) t)
|
||||
(setf (function-keys-enabled-p chat-win) t)
|
||||
(reader-start *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (message-queue-drain)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(when (> *chat-scroll-pos* 0)
|
||||
(incf *chat-scroll-pos* (length msgs)))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
;; Enter / Return — submit
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
(setf *chat-scroll-pos* 0)
|
||||
(input-submit *stream*)
|
||||
(chat-render chat-win chat-h 0)
|
||||
(status-render status-win))
|
||||
;; Backspace
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(input-backspace)
|
||||
(input-render input-win))
|
||||
;; Up arrow — history back
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let ((prev (input-history-nav :up)))
|
||||
(when prev
|
||||
(setf *input-buffer* (reverse (coerce prev 'list)))
|
||||
(input-render input-win))))
|
||||
;; Down arrow — history forward
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(let ((next (input-history-nav :down)))
|
||||
(if next
|
||||
(setf *input-buffer* (reverse (coerce next 'list)))
|
||||
(setf *input-buffer* nil))
|
||||
(input-render input-win)))
|
||||
;; Page Up — scroll chat back
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(let* ((hist-len (length *chat-history*))
|
||||
(view-h (- chat-h 2))
|
||||
(max-offset (max 0 (- hist-len view-h))))
|
||||
(setf *chat-scroll-pos*
|
||||
(min (+ *chat-scroll-pos* view-h) max-offset))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win)))
|
||||
;; Page Down — scroll chat forward
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf *chat-scroll-pos* (max 0 (- *chat-scroll-pos* (- chat-h 2))))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win))
|
||||
;; Printable character
|
||||
((characterp ch)
|
||||
(push ch *input-buffer*)
|
||||
(input-render input-win))
|
||||
;; Integer key code → character
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-buffer*)
|
||||
(input-render input-win))))))
|
||||
;; Re-render input on every tick (no key = buffer unchanged)
|
||||
(input-render input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
@@ -146,78 +146,3 @@
|
||||
(defskill :passepartout-programming-lisp
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
(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) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(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
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
|
||||
@@ -16,9 +16,9 @@
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag))
|
||||
(string-trim '(#\: #\space) private-tag)))
|
||||
privacy-tags))
|
||||
tags-list)))))
|
||||
tags-list))))
|
||||
|
||||
(defun org-privacy-strip (content)
|
||||
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
||||
@@ -217,7 +217,7 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (t) (string-trim '(#\:) t)) 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
|
||||
@@ -242,38 +242,3 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
(defskill :passepartout-programming-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(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
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
(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
|
||||
(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"))))
|
||||
|
||||
@@ -60,7 +60,7 @@ Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (t) (string-trim '(#\Space) t))
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
@@ -115,23 +115,24 @@ Returns T if note was created, nil if it already exists."
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(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)))
|
||||
(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))))
|
||||
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
@@ -213,10 +214,10 @@ Returns a list of link target strings."
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
|
||||
(defun archivist-run (context)
|
||||
(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 context))
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
|
||||
@@ -84,7 +84,9 @@
|
||||
("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")))
|
||||
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
@@ -97,30 +99,58 @@
|
||||
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)))
|
||||
(config-set env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(config-set 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 "~%")))
|
||||
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
|
||||
@@ -1,123 +0,0 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *embedding-queue* nil
|
||||
"List of object IDs pending embedding.")
|
||||
|
||||
(defvar *embedding-provider* :hashing
|
||||
"Active embedding provider: :hashing, :ollama, :openai.")
|
||||
|
||||
(defun embeddings-tokenize (text)
|
||||
"Split TEXT into lowercase word tokens, strip punctuation, discard short."
|
||||
(let ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]"
|
||||
(string-downcase (or text "")) " ")))
|
||||
(remove-if (lambda (w) (< (length w) 2))
|
||||
(uiop:split-string clean :separator '(#\Space #\Tab #\Newline)))))
|
||||
|
||||
(defun embeddings-hash-word (word dim)
|
||||
"Hash WORD to an index in [0, DIM)."
|
||||
(let ((hash 2166136261))
|
||||
(loop for c across word
|
||||
do (setf hash (logxor hash (char-code c)))
|
||||
(setf hash (mod (* hash 16777619) #x100000000)))
|
||||
(mod hash dim)))
|
||||
|
||||
(defun embeddings-hash-vector (text &key (dimensions 384))
|
||||
"Compute a hashing-trick vector for TEXT."
|
||||
(let* ((tokens (embeddings-tokenize text))
|
||||
(vec (make-array dimensions :initial-element 0.0d0 :element-type 'double-float)))
|
||||
(dolist (token tokens)
|
||||
(let* ((idx (embeddings-hash-word token dimensions))
|
||||
(sign (if (evenp (char-code (char token 0))) 1 -1)))
|
||||
(incf (aref vec idx) (coerce sign 'double-float))))
|
||||
(let ((norm (sqrt (loop for i below dimensions sum (expt (aref vec i) 2)))))
|
||||
(if (> norm 0.0d0)
|
||||
(loop for i below dimensions collect (/ (aref vec i) norm))
|
||||
(loop for i below dimensions collect 0.0d0)))))
|
||||
|
||||
(defun embeddings-compute (text &key (dimensions 384))
|
||||
"Compute embedding vector for TEXT.
|
||||
Tries *embedding-backend* first, falls back to hashing trick."
|
||||
(when *embedding-backend*
|
||||
(handler-case
|
||||
(let ((result (funcall *embedding-backend* text)))
|
||||
(when (and result (listp result) (> (length result) 0))
|
||||
(return-from embeddings-compute result)))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Backend failed (~a), fallback to hashing" c))))
|
||||
(embeddings-hash-vector text :dimensions dimensions))
|
||||
|
||||
(defun embedding-backend-ollama (text)
|
||||
"Generate embeddings via Ollama /api/embeddings."
|
||||
(let* ((url (or (uiop:getenv "OLLAMA_URL") "http://localhost:11434"))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||
(response (dex:post (format nil "~a/api/embeddings" url)
|
||||
:content (json:encode-json-to-string
|
||||
`((:model . ,model) (:prompt . ,text)))
|
||||
:headers '(("Content-Type" . "application/json")))))
|
||||
(when response
|
||||
(let* ((json (json:decode-json-from-string response))
|
||||
(embedding (cdr (assoc :embedding json))))
|
||||
(when embedding
|
||||
(coerce embedding 'list))))))
|
||||
|
||||
(defun embed-queue-object (obj)
|
||||
"Queue OBJ for embedding if it lacks a vector."
|
||||
(when (and obj (not (memory-object-vector obj)))
|
||||
(pushnew (memory-object-id obj) *embedding-queue* :test 'string=)))
|
||||
|
||||
(defun embed-object (obj)
|
||||
"Generate and store embedding vector for OBJ."
|
||||
(let* ((attrs (memory-object-attributes obj))
|
||||
(title (or (getf attrs :TITLE) ""))
|
||||
(text (or (memory-object-content obj) ""))
|
||||
(raw-tags (getf attrs :TAGS))
|
||||
(tag-list (if (listp raw-tags) raw-tags nil))
|
||||
(tags (if tag-list (format nil "~{~a~^ ~}" tag-list) ""))
|
||||
(combined (format nil "~a ~a ~a" title text tags))
|
||||
(vec (embeddings-compute combined)))
|
||||
(setf (memory-object-vector obj) vec)
|
||||
(log-message "EMBEDDING: Vector for ~a (~d dims)" (memory-object-id obj) (length vec))
|
||||
vec))
|
||||
|
||||
(defun embed-all-pending ()
|
||||
"Process all pending embeddings. Returns count."
|
||||
(let ((count 0))
|
||||
;; Drain queue
|
||||
(let ((pending *embedding-queue*))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (id pending)
|
||||
(let ((obj (gethash id *memory-store*)))
|
||||
(when (and obj (not (memory-object-vector obj)))
|
||||
(handler-case
|
||||
(progn (embed-object obj) (incf count))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed ~a: ~a" id c)))))))
|
||||
;; Fallback: scan store for objects without vectors
|
||||
(when (= count 0)
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(unless (memory-object-vector obj)
|
||||
(handler-case
|
||||
(progn (embed-object obj) (incf count))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed ~a: ~a"
|
||||
(memory-object-id obj) c)))))
|
||||
*memory-store*))
|
||||
(when (> count 0)
|
||||
(log-message "EMBEDDING: Batch processed ~d objects" count))
|
||||
count))
|
||||
|
||||
(defun embeddings-init (&key (provider *embedding-provider*))
|
||||
"Init embedding provider from EMBEDDING_PROVIDER env var."
|
||||
(let* ((env (uiop:getenv "EMBEDDING_PROVIDER"))
|
||||
(selected (or (and env (intern (string-upcase env) :keyword))
|
||||
provider)))
|
||||
(setf *embedding-provider* selected)
|
||||
(setf *embedding-backend*
|
||||
(case selected
|
||||
(:ollama #'embedding-backend-ollama)
|
||||
(t nil)))
|
||||
(log-message "EMBEDDING: Provider ~a, backend=~a" selected *embedding-backend*)
|
||||
selected))
|
||||
|
||||
(embeddings-init)
|
||||
@@ -15,16 +15,16 @@ Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((t (memory-object-type obj))
|
||||
(let ((obj-type (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq t type-filter)))
|
||||
(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 t type-counts 0))
|
||||
(incf (gethash obj-type type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
|
||||
87
lisp/system-model-embedding.lisp
Normal file
87
lisp/system-model-embedding.lisp
Normal file
@@ -0,0 +1,87 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *embedding-provider* :hashing
|
||||
"Active embedding provider: :hashing, :local, :openai.")
|
||||
|
||||
(defvar *embedding-queue* nil
|
||||
"Queue of text objects awaiting embedding.")
|
||||
|
||||
(defvar *embedding-batch-size* 10
|
||||
"Maximum texts per embedding API call.")
|
||||
|
||||
(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))))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(defun embedding-backend-hashing (text)
|
||||
"Fallback: produces a deterministic vector from the text hash."
|
||||
(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 embed-object (text)
|
||||
"Embed a single text string using the active backend."
|
||||
(let* ((selected (or *embedding-provider* :hashing))
|
||||
(backend (case selected
|
||||
(:local #'embedding-backend-local)
|
||||
(:openai #'embedding-backend-openai)
|
||||
(t #'embedding-backend-hashing))))
|
||||
(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, batch-process all queued objects."
|
||||
(let ((batch (nreverse *embedding-queue*)))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (item batch)
|
||||
(handler-case
|
||||
(let ((text (if (stringp item) item (format nil "~a" item))))
|
||||
(embed-object text))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
|
||||
|
||||
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)
|
||||
69
lisp/system-model-explorer.lisp
Normal file
69
lisp/system-model-explorer.lisp
Normal file
@@ -0,0 +1,69 @@
|
||||
(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)")
|
||||
|
||||
(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)))
|
||||
|
||||
(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))
|
||||
|
||||
(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)))
|
||||
|
||||
(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")))))
|
||||
|
||||
(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).")))
|
||||
@@ -1,5 +1,5 @@
|
||||
(defparameter *provider-configs*
|
||||
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
|
||||
'((: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"))
|
||||
@@ -13,24 +13,29 @@
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Ollama is always considered available."
|
||||
"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 ((eq provider :ollama) t)
|
||||
(key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(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))))
|
||||
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(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 (eq provider :ollama)
|
||||
(format nil "http://~a/v1/chat/completions" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(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)))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
@@ -71,11 +76,36 @@
|
||||
(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 *provider-configs*)))))
|
||||
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
|
||||
(member (car e) '(:local)))
|
||||
*provider-configs*))))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
|
||||
(defskill :passepartout-gateway-provider
|
||||
(defskill :passepartout-system-model-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
@@ -63,7 +63,7 @@ Returns model name or :skip."
|
||||
(t *model-cascade-chat*)))
|
||||
(entry (model-cascade-find
|
||||
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
|
||||
(if entry (cdr entry) :skip)))))
|
||||
(if entry (cdr entry) nil)))))
|
||||
|
||||
(defun model-router-init ()
|
||||
"Read env vars and wire model-select into *model-selector*."
|
||||
|
||||
16
lisp/system-model.lisp
Normal file
16
lisp/system-model.lisp
Normal file
@@ -0,0 +1,16 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun model-request (&key prompt system-prompt (provider :openrouter) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :passepartout-system-model
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
@@ -205,6 +205,15 @@ Validates that an incoming message has the minimum required structure: a plist w
|
||||
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.
|
||||
|
||||
@@ -305,6 +305,8 @@ Friendly error handler that replaces the raw SBCL debugger with a diagnostic mes
|
||||
(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
|
||||
|
||||
@@ -98,12 +98,18 @@ Heartbeats are silently dropped here — they should never generate an actuation
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
;; 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'" target))))))
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" actual-target))))))
|
||||
#+end_src
|
||||
|
||||
** System Actuator (action-system-execute)
|
||||
|
||||
@@ -43,7 +43,21 @@ This is not a cosmetic choice. It means the reasoning pipeline can generate, mod
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Probabilistic Engine State
|
||||
** 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 four pieces of global state that control how LLM requests are dispatched:
|
||||
|
||||
@@ -107,52 +121,33 @@ This is deliberately resilient. The system should never crash because an LLM pro
|
||||
(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 *backend-registry*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model-val (when *model-selector*
|
||||
(funcall *model-selector* backend context))))
|
||||
(if (eq model-val :skip)
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)
|
||||
(let* ((model (if model-val model-val nil))
|
||||
(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
|
||||
(log-message "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)
|
||||
|
||||
The ~think~ function is where the creative brain does its work. It assembles the full context for the LLM: the system identity, the available tools, the current global context from memory, the recent system logs, and any rejection trace from a previous failed proposal. It also collects augment strings from any skill that has registered a ~system-prompt-augment~ function.
|
||||
|
||||
A note on the augment system: skills can contribute context-specific mandates to the LLM prompt. For example, the REPL skill injects the "prototype in the REPL first" mandate when the context suggests the agent is editing Lisp code. This keeps domain-specific instructions out of the harness while still ensuring they appear in the prompt when relevant.
|
||||
|
||||
The LLM's response is expected to be a plist. If it is, it gets parsed and normalized. If it's a string that starts with ~(~ or ~[~, it's read as Lisp data. If it's neither, it falls back to a REQUEST with a MESSAGE action — the raw text.
|
||||
|
||||
** Pre-processing: strip markdown from LLM output
|
||||
|
||||
LLMs often wrap structured output in markdown code fences:
|
||||
|
||||
```lisp
|
||||
(:TYPE :REQUEST ...)
|
||||
```
|
||||
|
||||
This function strips the fences so the reader can parse the plist.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun markdown-strip (text)
|
||||
(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 (or (gethash backend *backend-registry*)
|
||||
(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
|
||||
(if (and model (not skip))
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt)))))
|
||||
(when skip
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
||||
(cond ((and (listp r) (eq (getf r :status) :success))
|
||||
(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))))))))))(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
@@ -219,13 +214,25 @@ The system prompt assembly order — identity, tools, context, logs, mandates
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (markdown-strip thought)))
|
||||
(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 (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(plist-keywords-normalize parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(let ((normalized (plist-keywords-normalize parsed)))
|
||||
;; Ensure explanation is present in the payload for policy gate
|
||||
(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."))))))
|
||||
#+end_src
|
||||
@@ -245,29 +252,29 @@ This architecture makes safety compositional: each skill adds one constraint. Th
|
||||
;; 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.
|
||||
Returns either a rejection plist (for :LOG or :EVENT errors) or the
|
||||
modified action (for approval-required or pass)."
|
||||
"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))
|
||||
(approval-action nil)
|
||||
(gates nil))
|
||||
;; Collect gates sorted by priority (highest first)
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(let ((gate (skill-deterministic-fn skill)))
|
||||
(when gate
|
||||
(let ((result (funcall gate current-action context)))
|
||||
(cond
|
||||
;; Approval-required: remember it and continue checking
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
;; Hard rejection: return immediately
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
;; Normal: update action
|
||||
(t (setf current-action result))))))))
|
||||
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
|
||||
*skill-registry*)
|
||||
(setf gates (sort gates #'> :key #'car))
|
||||
(dolist (gate-pair gates)
|
||||
(let ((result (funcall (cdr gate-pair) current-action context)))
|
||||
(cond
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
((and (listp result) result)
|
||||
(setf current-action result)))))
|
||||
(if approval-needed
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required
|
||||
|
||||
@@ -192,7 +192,10 @@ Both ~.org~ and ~.lisp~ files are included. For each skill, the ~.org~ file supp
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest")
|
||||
(string= n "security-dispatcher")
|
||||
(string= n "system-embedding-gateway"))))
|
||||
(string= n "system-model-router")
|
||||
(string= n "system-model-embedding")
|
||||
(string= n "system-model-explorer")
|
||||
(string= n "gateway-tui"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
@@ -315,26 +318,21 @@ The validation step is critical: invalid Lisp in an org block would crash the lo
|
||||
(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))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(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 "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" 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))))))
|
||||
(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)
|
||||
@@ -368,26 +366,21 @@ The same jailed package and symbol export process applies.
|
||||
(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* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(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 "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" 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))))))
|
||||
(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)
|
||||
|
||||
@@ -1,63 +0,0 @@
|
||||
#+TITLE: SKILL: LLM Gateway (org-skill-llm-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:llm:gateway:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-llm.lisp
|
||||
|
||||
* Overview
|
||||
The LLM Gateway dispatches inference requests to the registered probabilistic backends. It receives a prompt and system prompt, looks up the provider's registered function from ~*probabilistic-backends*~, calls it with the given model, and returns the result. This is the thin routing layer that sits between the reason pipeline and the provider-specific implementations in the unified-llm-backend skill.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Request Execution (gateway-llm-request)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-gateway-llm
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../lisp/gateway-llm.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 Gateway skill")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-llm-gateway-timeout
|
||||
"Tier 2 Chaos: Verify that LLM Gateway handles connection failures gracefully."
|
||||
(let ((old-host (uiop:getenv "OLLAMA_HOST")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "OLLAMA_HOST") "localhost:1")
|
||||
(let ((fn (or (find-symbol "GATEWAY-LLM-REQUEST" :passepartout.gateway-llm)
|
||||
(find-symbol "GATEWAY-LLM-REQUEST" :passepartout))))
|
||||
(if fn
|
||||
(let ((result (funcall fn :prompt "hello" :provider :ollama)))
|
||||
(fiveam:is (eq (getf result :status) :error))
|
||||
(fiveam:is (uiop:string-prefix-p "Ollama Failure" (getf result :message))))
|
||||
(fiveam:fail "Could not find EXECUTE-LLM-REQUEST symbol"))))
|
||||
(if old-host
|
||||
(setf (uiop:getenv "OLLAMA_HOST") old-host)
|
||||
(sb-posix:unsetenv "OLLAMA_HOST")))))
|
||||
#+end_src
|
||||
@@ -1,52 +1,38 @@
|
||||
#+TITLE: SKILL: Gateway Manager (org-skill-gateway-manager.org)
|
||||
#+TITLE: SKILL: Gateway Messaging (org-skill-gateway-messaging.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:gateway:manager:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-manager.lisp
|
||||
#+FILETAGS: :skill:gateway:messaging:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-messaging.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Gateway Manager is the unified interface for all external messaging platforms. It handles Telegram, Signal, and any future gateway through a common pattern: a registry of poll/send function pairs, a configuration hash table for tokens and intervals, and a background thread per gateway that polls for new messages.
|
||||
~gateway-messaging~ bridges Passepartout to external messaging platforms — Telegram, Signal, and any future service that speaks HTTP or has a CLI.
|
||||
|
||||
Each gateway follows the same lifecycle:
|
||||
1. **Register** — the gateway's poll and send functions are registered in ~*gateway-registry*~
|
||||
2. **Link** — the user provides a token; it's stored in the vault and a polling thread is started
|
||||
3. **Poll** — the thread calls the poll function on an interval, injecting received messages into the pipeline
|
||||
4. **Unlink** — the thread is destroyed, the config is removed
|
||||
5. **Act** — when the agent needs to send a message, it dispatches to the gateway's send function via the generic actuator mechanism
|
||||
Each gateway follows the same pattern:
|
||||
1. **Registration** — a poll function and a send function are registered in ~*gateway-registry*~ by name ("telegram", "signal")
|
||||
2. **Linking** — the user provides a token (Telegram bot token) or account name (Signal CLI); it's stored in the vault and a polling thread starts
|
||||
3. **Polling** — the background thread calls the poll function every N seconds; inbound messages are injected into the daemon as ~:EVENT~ signals via ~stimulus-inject~
|
||||
4. **Sending** — when ~telegram-send~ or ~signal-send~ is invoked as an actuator (registered via ~register-actuator~), it formats the message and pushes it through the platform's API
|
||||
|
||||
The gateway management functions (~messaging-link~, ~messaging-unlink~, ~messaging-list~, ~messaging-list-print~) are what the CLI's =passepartout gateway= subcommand calls. The old ~gateway-manager~ skill had ~gateway-link~/~gateway-unlink~/~gateway-list~ printed with the same signatures; the rename to ~messaging-*~ aligns the public API with the skill name while keeping the internal engine functions (~gateway-start~, ~gateway-stop~) as-is since they're implementation details.
|
||||
|
||||
This replaces the old ~gateway-manager~ skill. The Telegram/Signal platform code is unchanged; only the management entry points and the defskill name changed.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Platform state — configs
|
||||
Storage for active gateway connections: tokens, polling threads, and intervals.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Data
|
||||
#+begin_src lisp
|
||||
(defvar *gateway-configs* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:token :thread :interval :enabled)")
|
||||
#+end_src
|
||||
"Maps platform name to plist (:token :thread :interval :enabled)")
|
||||
|
||||
** Platform state — registry
|
||||
Registration of available gateway implementations: each platform registers its poll and send functions here.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *gateway-registry* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
|
||||
"Maps platform name to plist (:poll-fn :send-fn :default-interval)")
|
||||
#+end_src
|
||||
|
||||
** Telegram Implementation
|
||||
|
||||
When a Telegram message arrives, the gateway first checks whether it is a
|
||||
HITL approval/denial command via ~hitl-handle-message~. If consumed,
|
||||
the message never enters the cognitive pipeline. Otherwise, it is injected
|
||||
as a normal ~:user-input~ event via ~stimulus-inject~.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Telegram
|
||||
#+begin_src lisp
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
|
||||
#+end_src
|
||||
** telegram-poll
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun telegram-poll ()
|
||||
"Polls Telegram for new messages and injects them into the harness."
|
||||
(let* ((token (telegram-get-token)))
|
||||
@@ -65,19 +51,15 @@ as a normal ~:user-input~ event via ~stimulus-inject~.
|
||||
(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))))))
|
||||
(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)))))))
|
||||
|
||||
#+end_src
|
||||
** telegram-send
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun telegram-send (action context)
|
||||
"Sends a message via Telegram."
|
||||
(declare (ignore context))
|
||||
@@ -87,7 +69,6 @@ as a normal ~:user-input~ event via ~stimulus-inject~.
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(log-message "TELEGRAM: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
@@ -96,22 +77,12 @@ as a normal ~:user-input~ event via ~stimulus-inject~.
|
||||
`((chat_id . ,chat-id) (text . ,text)))))
|
||||
(error (c) (log-message "TELEGRAM ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Signal Implementation
|
||||
|
||||
Signal messages follow the same pattern as Telegram: ~hitl-handle-message~
|
||||
is called first, and only non-HITL messages are injected into the pipeline.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Signal
|
||||
#+begin_src lisp
|
||||
(defun signal-get-account ()
|
||||
(vault-get-secret :signal))
|
||||
|
||||
#+end_src
|
||||
** signal-poll
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun signal-poll ()
|
||||
"Polls Signal for new messages and injects them into the harness."
|
||||
(let ((account (signal-get-account)))
|
||||
@@ -119,7 +90,7 @@ is called first, and only non-HITL messages are injected into the pipeline.
|
||||
(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)))
|
||||
(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)))
|
||||
@@ -127,19 +98,15 @@ is called first, and only non-HITL messages are injected into the pipeline.
|
||||
(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))))))))
|
||||
(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))))))
|
||||
|
||||
#+end_src
|
||||
** signal-send
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun signal-send (action context)
|
||||
"Sends a message via Signal."
|
||||
(declare (ignore context))
|
||||
@@ -149,16 +116,13 @@ is called first, and only non-HITL messages are injected into the pipeline.
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(log-message "SIGNAL: Sending message to ~a..." chat-id)
|
||||
(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
|
||||
|
||||
** Gateway Registry Initialization
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Registry initialization
|
||||
#+begin_src lisp
|
||||
(defun gateway-registry-initialize ()
|
||||
"Registers all built-in gateway handlers."
|
||||
@@ -170,24 +134,12 @@ is called first, and only non-HITL messages are injected into the pipeline.
|
||||
(list :poll-fn #'signal-poll
|
||||
:send-fn #'signal-send
|
||||
:default-interval 5)))
|
||||
#+end_src
|
||||
|
||||
** Core gateway functions
|
||||
|
||||
*** Configuration check (gateway-configured-p)
|
||||
Returns T if a platform has a stored token in ~*gateway-configs*~.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-configured-p (platform)
|
||||
"Returns T if a platform has a stored token."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
(and config (getf config :token))))
|
||||
#+end_src
|
||||
|
||||
*** Active check (gateway-active-p)
|
||||
Returns T if a platform's polling thread is alive.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-active-p (platform)
|
||||
"Returns T if a platform's polling thread is alive."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
@@ -196,11 +148,9 @@ Returns T if a platform's polling thread is alive.
|
||||
(bt:thread-alive-p (getf config :thread)))))
|
||||
#+end_src
|
||||
|
||||
*** Link a gateway (gateway-link)
|
||||
The main entry point for linking. Validates the registry entry, stores the token in the vault, starts the polling thread, and updates the config.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Gateway management (link/unlink)
|
||||
#+begin_src lisp
|
||||
(defun gateway-link (platform token)
|
||||
(defun messaging-link (platform token)
|
||||
"Links a platform with a token and starts polling."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(unless (gethash platform-lc *gateway-registry*)
|
||||
@@ -208,7 +158,7 @@ The main entry point for linking. Validates the registry entry, stores the token
|
||||
platform (loop for k being the hash-keys of *gateway-registry* collect k)))
|
||||
(when (or (null token) (zerop (length token)))
|
||||
(error "Token cannot be empty"))
|
||||
(log-message "GATEWAY: Linking to ~a..." platform-lc)
|
||||
(log-message "MESSAGING: Linking to ~a..." platform-lc)
|
||||
(gateway-unlink platform-lc)
|
||||
(let* ((registry-entry (gethash platform-lc *gateway-registry*))
|
||||
(interval (or (getf registry-entry :default-interval) 5)))
|
||||
@@ -216,28 +166,21 @@ The main entry point for linking. Validates the registry entry, stores the token
|
||||
(list :token token :interval interval :enabled t))
|
||||
(vault-set-secret (intern (string-upcase platform-lc) :keyword) token)
|
||||
(gateway-start platform-lc)
|
||||
(log-message "GATEWAY: Successfully linked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Successfully linked ~a" platform-lc)
|
||||
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
|
||||
t)))
|
||||
#+end_src
|
||||
|
||||
*** Unlink a gateway (gateway-unlink)
|
||||
Stops the polling thread and removes the config entry.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-unlink (platform)
|
||||
(defun messaging-unlink (platform)
|
||||
"Unlinks a platform and stops its polling thread."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(gateway-stop platform-lc)
|
||||
(remhash platform-lc *gateway-configs*)
|
||||
(log-message "GATEWAY: Unlinked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Unlinked ~a" platform-lc)
|
||||
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
*** Start polling (gateway-start)
|
||||
Creates a background thread that calls the platform's poll function on an interval. The thread checks the ~:enabled~ flag on each cycle so it can be stopped cleanly via ~gateway-stop~.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Polling thread management
|
||||
#+begin_src lisp
|
||||
(defun gateway-start (platform)
|
||||
"Starts the polling thread for a linked gateway."
|
||||
@@ -255,29 +198,22 @@ Creates a background thread that calls the platform's poll function on an interv
|
||||
(funcall poll-fn))
|
||||
(sleep interval)))
|
||||
:name (format nil "passepartout-~a-gateway" platform-lc)))
|
||||
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
|
||||
#+end_src
|
||||
(log-message "MESSAGING: Started ~a polling (interval: ~as)" platform-lc interval))))))))
|
||||
|
||||
*** Stop polling (gateway-stop)
|
||||
Destroys the polling thread and nulls the thread reference.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-stop (platform)
|
||||
"Stops the polling thread for a gateway."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :thread))
|
||||
(when (bt:thread-alive-p (getf config :thread))
|
||||
(log-message "GATEWAY: Stopping ~a polling thread" platform-lc)
|
||||
(log-message "MESSAGING: Stopping ~a polling thread" platform-lc)
|
||||
(bt:destroy-thread (getf config :thread))))
|
||||
(setf (getf config :thread) nil))))
|
||||
#+end_src
|
||||
|
||||
*** List gateways (gateway-list)
|
||||
Returns a list of plists, one per registered platform, with :platform, :configured, and :active keys.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Listing
|
||||
#+begin_src lisp
|
||||
(defun gateway-list ()
|
||||
(defun messaging-list ()
|
||||
"Returns a list of all gateways with their status."
|
||||
(loop for platform being the hash-keys of *gateway-registry*
|
||||
collect (let ((configured (gateway-configured-p platform))
|
||||
@@ -285,17 +221,12 @@ Returns a list of plists, one per registered platform, with :platform, :configur
|
||||
(list :platform platform
|
||||
:configured configured
|
||||
:active active))))
|
||||
#+end_src
|
||||
|
||||
*** Print gateways (gateway-list-print)
|
||||
Formats ~gateway-list~ for display in the CLI.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-list-print ()
|
||||
(defun messaging-list-print ()
|
||||
"Prints a formatted table of gateways."
|
||||
(format t "~%")
|
||||
(format t " ~20@A ~12@A ~10@A~%" "PLATFORM" "CONFIGURED" "STATUS")
|
||||
(dolist (gw (gateway-list))
|
||||
(dolist (gw (messaging-list))
|
||||
(format t " ~20@A ~12@A ~10@A~%"
|
||||
(getf gw :platform)
|
||||
(if (getf gw :configured) "yes" "no")
|
||||
@@ -306,9 +237,7 @@ Formats ~gateway-list~ for display in the CLI.
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
*** Start all configured gateways (gateway-start-all)
|
||||
Called during boot to start all gateways that have tokens stored in their configs.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Boot
|
||||
#+begin_src lisp
|
||||
(defun gateway-start-all ()
|
||||
"Called at boot to start all configured gateways."
|
||||
@@ -319,23 +248,15 @@ Called during boot to start all gateways that have tokens stored in their config
|
||||
(gateway-start platform)))))
|
||||
#+end_src
|
||||
|
||||
** Actuator Registration
|
||||
Register :telegram and :signal as actuators for outbound messages.
|
||||
** Registration and boot
|
||||
#+begin_src lisp
|
||||
(register-actuator :telegram #'telegram-send)
|
||||
(register-actuator :signal #'signal-send)
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-gateway-manager
|
||||
(defskill :passepartout-gateway-messaging
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
Initialize registry and start configured gateways on skill load.
|
||||
#+begin_src lisp
|
||||
(gateway-registry-initialize)
|
||||
(gateway-start-all)
|
||||
#+end_src
|
||||
#+end_src
|
||||
184
org/gateway-tui-main.org
Normal file
184
org/gateway-tui-main.org
Normal file
@@ -0,0 +1,184 @@
|
||||
#+TITLE: Passepartout TUI — Controller
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-main.lisp
|
||||
|
||||
* Controller
|
||||
|
||||
Event handlers + daemon I/O + main loop.
|
||||
|
||||
** Event Handlers
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun on-key (&rest args)
|
||||
(let ((ch (car args)))
|
||||
(cond
|
||||
;; Enter
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
|
||||
(when (> (length text) 0)
|
||||
(push text (st :input-history))
|
||||
(setf (st :input-hpos) 0)
|
||||
(setf (st :scroll-offset) 0)
|
||||
(cond
|
||||
;; /eval command
|
||||
((and (>= (length text) 6)
|
||||
(string-equal (subseq text 0 6) "/eval "))
|
||||
(handler-case
|
||||
(let* ((*read-eval* t)
|
||||
(*package* (find-package :passepartout.gateway-tui))
|
||||
(r (eval (read-from-string (subseq text 6)))))
|
||||
(add-msg :system (format nil "=> ~s" r)))
|
||||
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
|
||||
;; Normal message
|
||||
(t
|
||||
(add-msg :user text)
|
||||
(send-daemon (list :type :event
|
||||
:payload (list :sensor :user-input :text text)))))
|
||||
(setf (st :input-buffer) nil)
|
||||
(setf (st :dirty) (list t t t)))))
|
||||
;; Backspace
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(when (st :input-buffer) (pop (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
;; Up arrow
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let* ((h (st :input-history)) (p (st :input-hpos)))
|
||||
(when (and h (< p (1- (length h))))
|
||||
(incf (st :input-hpos))
|
||||
(setf (st :input-buffer)
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list)))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; Down arrow
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(when (> (st :input-hpos) 0)
|
||||
(decf (st :input-hpos))
|
||||
(let ((h (st :input-history)))
|
||||
(setf (st :input-buffer)
|
||||
(if (and h (< (st :input-hpos) (length h)))
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list))
|
||||
nil))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; PageUp
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(incf (st :scroll-offset) 5)
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; PageDown
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; Printable
|
||||
(t
|
||||
(let ((chr (typecase ch
|
||||
(character ch)
|
||||
(integer (code-char ch))
|
||||
(t nil))))
|
||||
(when (and chr (graphic-char-p chr))
|
||||
(push chr (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t))))))))
|
||||
|
||||
(defun on-daemon-msg (msg)
|
||||
(let* ((payload (getf msg :payload))
|
||||
(text (getf payload :text))
|
||||
(action (getf payload :action)))
|
||||
(cond
|
||||
(text (add-msg :agent text))
|
||||
((eq action :handshake)
|
||||
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
|
||||
(t (add-msg :agent (format nil "~a" msg))))))
|
||||
#+end_src
|
||||
|
||||
** Daemon Communication
|
||||
#+begin_src lisp
|
||||
(defun send-daemon (msg)
|
||||
(let ((s (st :stream)))
|
||||
(when (and s (open-stream-p s))
|
||||
(handler-case
|
||||
(progn
|
||||
(format s "~a" (frame-message msg))
|
||||
(finish-output s))
|
||||
(error (c) (log-message "TUI-SEND: ~a" c))))))
|
||||
|
||||
(defun recv-daemon (s)
|
||||
(handler-case
|
||||
(let* ((hdr (make-string 6)) (n 0))
|
||||
(loop while (< n 6)
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon 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 s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char buf i) ch)))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string buf)))))
|
||||
(error (c) (log-message "TUI-RECV: ~a" c) nil)))
|
||||
|
||||
(defun reader-loop (s)
|
||||
(loop while (and (st :running) (open-stream-p s))
|
||||
do (let ((msg (recv-daemon s)))
|
||||
(when msg (queue-event (list :type :daemon :payload msg))))))
|
||||
#+end_src
|
||||
|
||||
** Connection
|
||||
#+begin_src lisp
|
||||
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||
(handler-case
|
||||
(let ((s (usocket:socket-connect host port :element-type 'character)))
|
||||
(setf (st :stream) (usocket:socket-stream s) (st :connected) t)
|
||||
(bt:make-thread (lambda () (reader-loop (st :stream))) :name "tui-reader")
|
||||
(add-msg :system "* Connected *")
|
||||
t)
|
||||
(error (c)
|
||||
(add-msg :system (format nil "* Connection failed: ~a *" c))
|
||||
nil)))
|
||||
|
||||
(defun disconnect-daemon ()
|
||||
(when (st :stream)
|
||||
(ignore-errors (close (st :stream)))
|
||||
(setf (st :stream) nil (st :connected) nil)
|
||||
(add-msg :system "* Disconnected *")))
|
||||
#+end_src
|
||||
|
||||
** Main Loop
|
||||
#+begin_src lisp
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
|
||||
(ch (- h 5))
|
||||
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(st :dirty) (list t t t))
|
||||
(connect-daemon)
|
||||
(when (> swank-port 0)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload :swank :silent t)
|
||||
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
||||
:port swank-port :dont-close t)
|
||||
(add-msg :system
|
||||
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
|
||||
(error ()
|
||||
(add-msg :system "* Swank unavailable *"))))
|
||||
(loop while (st :running) do
|
||||
(dolist (ev (drain-queue))
|
||||
(when (eq (getf ev :type) :daemon)
|
||||
(on-daemon-msg (getf ev :payload))))
|
||||
(let ((ch (get-char iw)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(on-key ch)))
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon))))
|
||||
#+end_src
|
||||
55
org/gateway-tui-model.org
Normal file
55
org/gateway-tui-model.org
Normal file
@@ -0,0 +1,55 @@
|
||||
#+TITLE: Passepartout TUI — Model
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-model.lisp
|
||||
|
||||
* Model
|
||||
|
||||
The TUI state is a single plist accessed via ~st~ / ~(setf st)~.
|
||||
All state mutation flows through event handlers in the controller.
|
||||
|
||||
** Package + State
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
|
||||
(:export :tui-main :st :add-msg :now :input-string
|
||||
:queue-event :drain-queue :init-state
|
||||
:view-status :view-chat :view-input :redraw))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *state* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
||||
|
||||
(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-buffer nil :input-history nil :input-hpos 0
|
||||
:messages nil :scroll-offset 0 :dirty (list nil nil nil))))
|
||||
#+end_src
|
||||
|
||||
** Helpers
|
||||
#+begin_src lisp
|
||||
(defun now ()
|
||||
(multiple-value-bind (h m) (get-decoded-time)
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun input-string ()
|
||||
(coerce (reverse (st :input-buffer)) 'string))
|
||||
|
||||
(defun add-msg (role content)
|
||||
(push (list :role role :content content :time (now)) (st :messages))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
#+end_src
|
||||
|
||||
** Event Queue
|
||||
#+begin_src 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
|
||||
79
org/gateway-tui-view.org
Normal file
79
org/gateway-tui-view.org
Normal file
@@ -0,0 +1,79 @@
|
||||
#+TITLE: Passepartout TUI — View
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-view.lisp
|
||||
|
||||
* View
|
||||
|
||||
Pure render functions. Each takes a Croatoan window and current state.
|
||||
State is read via ~(st :key)~ — no mutation here.
|
||||
|
||||
** Status Bar
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun view-status (win)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(add-string win
|
||||
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a"
|
||||
(if (st :connected) "● Connected" "○ Disconnected")
|
||||
(string-upcase (string (st :mode)))
|
||||
(length (st :messages))
|
||||
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
|
||||
:y 1 :x 1 :fgcolor (if (st :connected) :green :red))
|
||||
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Chat Area
|
||||
#+begin_src lisp
|
||||
(defun view-chat (win h)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 78))
|
||||
(msgs (reverse (st :messages)))
|
||||
(max-lines (- h 2))
|
||||
(total (length msgs))
|
||||
(start (max 0 (- total max-lines (st :scroll-offset))))
|
||||
(y 1))
|
||||
(loop for i from start below total
|
||||
while (< y (1- h))
|
||||
do (let ((msg (nth i msgs)))
|
||||
(let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(time (or (getf msg :time) ""))
|
||||
(label (case role
|
||||
(:user (format nil "⬆ [~a] ~a" time content))
|
||||
(:agent (format nil "⬇ [~a] ~a" time content))
|
||||
(:system (format nil " [~a] ~a" time content))
|
||||
(t (format nil " [~a] ~a" time content))))
|
||||
(color (case role
|
||||
(:user :green)
|
||||
(:agent :white)
|
||||
(:system :yellow)
|
||||
(t :white))))
|
||||
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
|
||||
(incf y)))))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Input Line
|
||||
#+begin_src lisp
|
||||
(defun view-input (win)
|
||||
(let* ((text (input-string))
|
||||
(w (or (width win) 78))
|
||||
(clip (min (length text) (1- w))))
|
||||
(clear win)
|
||||
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
|
||||
(setf (cursor-position win) (list 0 clip)))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Redraw (dirty-flag dispatch)
|
||||
#+begin_src lisp
|
||||
(defun redraw (sw cw ch iw)
|
||||
(destructuring-bind (sd cd id) (st :dirty)
|
||||
(when sd (view-status sw))
|
||||
(when cd (view-chat cw ch))
|
||||
(when id (view-input iw))
|
||||
(setf (st :dirty) (list nil nil nil))))
|
||||
#+end_src
|
||||
@@ -1,493 +0,0 @@
|
||||
#+TITLE: Passepartout TUI Client (Standalone)
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :tui:ux:client:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The TUI Client is a standalone ncurses application built on Croatoan that
|
||||
connects to the daemon via TCP. It provides a three-pane interface: a status
|
||||
bar at top, scrollable chat history in the middle, and a fixed input line at
|
||||
the bottom.
|
||||
|
||||
Unlike the CLI gateway (which is a single request-response cycle), the TUI
|
||||
is a persistent connection. It maintains a background reader thread that
|
||||
listens for incoming messages from the daemon and enqueues them for display.
|
||||
This allows the agent to send messages to the user asynchronously — tool
|
||||
results, heartbeat notifications, and autonomous decisions appear in the
|
||||
chat window without the user having to ask.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
The TUI lives in its own package (~passepartout.gateway-tui~) so it doesn't pollute the harness namespace. It depends on Croatoan (ncurses bindings), usocket (TCP client), and bordeaux-threads (background reader).
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
#+end_src
|
||||
|
||||
** Connection state
|
||||
|
||||
The daemon host and port. Defaults to localhost:9105.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-host* "localhost")
|
||||
#+end_src
|
||||
|
||||
** *daemon-port*
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-port* 9105)
|
||||
#+end_src
|
||||
|
||||
** Socket and stream
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *socket* nil)
|
||||
#+end_src
|
||||
|
||||
** *stream*
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *stream* nil)
|
||||
#+end_src
|
||||
|
||||
** Chat history
|
||||
|
||||
Each message is a list ~(:text "..." :time ...)~ for structured rendering.
|
||||
The third value is the display string with timestamp prepended.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *chat-history* nil)
|
||||
#+end_src
|
||||
|
||||
** Chat scroll position
|
||||
|
||||
Offset from the bottom of the history. 0 = latest messages visible.
|
||||
Positive values scroll back. Protected by ~*queue-lock*~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *chat-scroll-pos* 0)
|
||||
#+end_src
|
||||
|
||||
** Input buffer
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *input-buffer* nil)
|
||||
#+end_src
|
||||
|
||||
** Input history
|
||||
|
||||
Previous commands for recall via up/down arrows.
|
||||
|
||||
- ~*input-history*~: list of submitted command strings, newest first.
|
||||
- ~*input-history-pos*~: current position in the history list (0 = newest,
|
||||
nil = fresh input).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *input-history* nil)
|
||||
(defvar *input-history-pos* nil)
|
||||
#+end_src
|
||||
|
||||
** Running flag
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *is-running* t)
|
||||
#+end_src
|
||||
|
||||
** Incoming message queue
|
||||
|
||||
Thread-safe queue for messages received by the background reader.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
#+end_src
|
||||
|
||||
** *incoming*
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *incoming* nil)
|
||||
#+end_src
|
||||
|
||||
** Utility functions
|
||||
|
||||
*** Debug logging
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/passepartout-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))))
|
||||
#+end_src
|
||||
|
||||
*** Message queue (message-queue-push)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun message-queue-push (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming* (append *incoming* (list msg)))))
|
||||
#+end_src
|
||||
|
||||
*** Message queue (message-queue-drain)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun message-queue-drain ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming*))
|
||||
(setf *incoming* nil)
|
||||
msgs)))
|
||||
#+end_src
|
||||
|
||||
*** Timestamp formatting
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun timestamp-now ()
|
||||
"Return a short HH:MM timestamp string."
|
||||
(multiple-value-bind (s m h) (decode-universal-time (get-universal-time))
|
||||
(declare (ignore s))
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
#+end_src
|
||||
|
||||
** Input rendering
|
||||
|
||||
Draws the input line with a ~▶~ prompt. Handles the case where the input
|
||||
buffer is empty (shows a dimmed hint).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun input-render (win)
|
||||
(clear win)
|
||||
(let ((text (coerce (reverse *input-buffer*) 'string)))
|
||||
(if (> (length text) 0)
|
||||
(add-string win (format nil "▶ ~a" text) :y 0 :x 1)
|
||||
(add-string win "▶ " :y 0 :x 1)))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Rendering (chat-render / status-render)
|
||||
|
||||
*** Chat history renderer
|
||||
|
||||
Renders the chat history with scroll support. ~offset~ is the number of
|
||||
lines from the bottom to skip (0 = newest visible). Each message is shown
|
||||
with its timestamp.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun chat-render (win h &optional (offset 0))
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history *chat-history*)
|
||||
(len (length history))
|
||||
(start (max 0 (- len view-height offset)))
|
||||
(end (min len (+ start view-height))))
|
||||
(loop for i from start below end
|
||||
for msg in (subseq history start end)
|
||||
for row from 1
|
||||
do (add-string win (format nil "│ ~a" msg) :y row :x 2)))
|
||||
(refresh win)))
|
||||
#+end_src
|
||||
|
||||
*** Status bar renderer
|
||||
|
||||
Draws a compact status line showing connection status, message count, and
|
||||
scroll indicator.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun status-render (win)
|
||||
(when win
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((status (if (and *stream* (open-stream-p *stream*)) "●" "○"))
|
||||
(msgs (length *chat-history*))
|
||||
(scroll-indicator (if (> *chat-scroll-pos* 0)
|
||||
(format nil " ↑~a" *chat-scroll-pos*)
|
||||
""))
|
||||
(time (timestamp-now)))
|
||||
(add-string win (format nil "│ ~a PASSEPARTOUT [~a msgs]~a ~a"
|
||||
status msgs scroll-indicator time)
|
||||
:y 1 :x 2)))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Input handling
|
||||
|
||||
*** Handle backspace
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun input-backspace ()
|
||||
(pop *input-buffer*))
|
||||
#+end_src
|
||||
|
||||
*** Save current buffer to history
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun input-history-push (cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(setf *input-history* (cons cmd *input-history*))
|
||||
(setf *input-history-pos* nil)))
|
||||
#+end_src
|
||||
|
||||
*** Navigate input history
|
||||
|
||||
Moves ~*input-history-pos*~ backward (up) or forward (down). Returns the
|
||||
appropriate history entry, or nil if at the end.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun input-history-nav (direction)
|
||||
(let ((len (length *input-history*)))
|
||||
(if (= len 0)
|
||||
nil
|
||||
(case direction
|
||||
(:up
|
||||
(let ((pos (if *input-history-pos*
|
||||
(min (1+ *input-history-pos*) (1- len))
|
||||
0)))
|
||||
(setf *input-history-pos* pos)
|
||||
(nth pos *input-history*)))
|
||||
(:down
|
||||
(if *input-history-pos*
|
||||
(if (= *input-history-pos* 0)
|
||||
(progn (setf *input-history-pos* nil) nil)
|
||||
(let ((pos (1- *input-history-pos*)))
|
||||
(setf *input-history-pos* pos)
|
||||
(nth pos *input-history*)))
|
||||
nil))))))
|
||||
#+end_src
|
||||
|
||||
*** Handle return
|
||||
|
||||
Sends the accumulated input as a framed protocol message to the daemon.
|
||||
Also handles ~/exit~ and ~/clear~ client-side commands.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun input-submit (stream)
|
||||
(let ((cmd (coerce (reverse *input-buffer*) 'string)))
|
||||
(setf *input-buffer* nil)
|
||||
(setf *input-history-pos* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(input-history-push cmd)
|
||||
(let* ((ts (timestamp-now))
|
||||
(display (format nil "⬆ [~a] ~a" ts cmd)))
|
||||
(push display *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) (setf *chat-scroll-pos* 0))))
|
||||
#+end_src
|
||||
|
||||
** Background Reader (reader-start)
|
||||
|
||||
A dedicated thread that continuously reads framed messages from the daemon's
|
||||
TCP stream. Messages are parsed and enqueued with timestamps for the main
|
||||
loop to display.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun reader-start (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))
|
||||
(payload (getf msg :payload))
|
||||
(ts (timestamp-now)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(message-queue-push (format nil "⬇ [~a] * Connected *" ts)))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(message-queue-push (format nil "⬇ [~a] ~a" ts text)))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(message-queue-push "⬇ [--:--] ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "passepartout-tui-reader"))
|
||||
#+end_src
|
||||
|
||||
** Main Entry Point (main)
|
||||
|
||||
Top-level entry point with three-pane layout:
|
||||
|
||||
```
|
||||
┌─────────────────────┐
|
||||
│ Status bar (1 row) │
|
||||
├─────────────────────┤
|
||||
│ Chat (h-6) │
|
||||
├─────────────────────┤
|
||||
│ Input (1 row) │
|
||||
└─────────────────────┘
|
||||
```
|
||||
|
||||
Keybindings:
|
||||
- Enter / Return — submit current input
|
||||
- Backspace — delete last character
|
||||
- Up / Down — navigate input history
|
||||
- Page Up / Page Down — scroll chat history
|
||||
- /exit — disconnect and quit
|
||||
- /clear — clear chat history
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+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))
|
||||
(status-h 3)
|
||||
(input-h 1)
|
||||
(chat-h (- h status-h input-h 1))
|
||||
(status-win (make-instance 'window :height status-h :width (- w 2) :y 0 :x 1))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y status-h :x 1))
|
||||
(input-win (make-instance 'window :height input-h :width (- w 2) :y (- h input-h 1) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(setf (function-keys-enabled-p input-win) t)
|
||||
(setf (function-keys-enabled-p chat-win) t)
|
||||
(reader-start *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (message-queue-drain)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(when (> *chat-scroll-pos* 0)
|
||||
(incf *chat-scroll-pos* (length msgs)))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
;; Enter / Return — submit
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
(setf *chat-scroll-pos* 0)
|
||||
(input-submit *stream*)
|
||||
(chat-render chat-win chat-h 0)
|
||||
(status-render status-win))
|
||||
;; Backspace
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(input-backspace)
|
||||
(input-render input-win))
|
||||
;; Up arrow — history back
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let ((prev (input-history-nav :up)))
|
||||
(when prev
|
||||
(setf *input-buffer* (reverse (coerce prev 'list)))
|
||||
(input-render input-win))))
|
||||
;; Down arrow — history forward
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(let ((next (input-history-nav :down)))
|
||||
(if next
|
||||
(setf *input-buffer* (reverse (coerce next 'list)))
|
||||
(setf *input-buffer* nil))
|
||||
(input-render input-win)))
|
||||
;; Page Up — scroll chat back
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(let* ((hist-len (length *chat-history*))
|
||||
(view-h (- chat-h 2))
|
||||
(max-offset (max 0 (- hist-len view-h))))
|
||||
(setf *chat-scroll-pos*
|
||||
(min (+ *chat-scroll-pos* view-h) max-offset))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win)))
|
||||
;; Page Down — scroll chat forward
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf *chat-scroll-pos* (max 0 (- *chat-scroll-pos* (- chat-h 2))))
|
||||
(chat-render chat-win chat-h *chat-scroll-pos*)
|
||||
(status-render status-win))
|
||||
;; Printable character
|
||||
((characterp ch)
|
||||
(push ch *input-buffer*)
|
||||
(input-render input-win))
|
||||
;; Integer key code → character
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-buffer*)
|
||||
(input-render input-win))))))
|
||||
;; Re-render input on every tick (no key = buffer unchanged)
|
||||
(input-render input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
#+end_src
|
||||
|
||||
** REPL test script (tmux)
|
||||
|
||||
#+begin_src bash :tangle no
|
||||
#!/bin/bash
|
||||
SESSION="oct-tui-test"
|
||||
tmux new-session -d -s "$SESSION" \
|
||||
-e OC_CONFIG_DIR="$HOME/.config/passepartout" \
|
||||
-e PASSEPARTOUT_DATA_DIR="$HOME/.local/share/passepartout" \
|
||||
-e TERM="screen-256color" \
|
||||
"sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames \"quicklisp/setup.lisp\" (user-homedir-pathname)))' \
|
||||
--eval '(push (truename \"$HOME/.local/share/passepartout/\") asdf:*central-registry*)' \
|
||||
--eval '(ql:quickload :passepartout/tui)' \
|
||||
--eval '(passepartout.gateway-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
|
||||
@@ -215,7 +215,7 @@ The skill has four layers:
|
||||
|
||||
* Test Suite
|
||||
Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
#+begin_src lisp :tangle ../lisp/programming-lisp.lisp
|
||||
#+begin_src lisp :tangle ../tests/programming-lisp-tests.lisp
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
@@ -33,9 +33,9 @@ Structural manipulation tools for Org-mode files. This skill handles reading, wr
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag))
|
||||
(string-trim '(#\: #\space) private-tag)))
|
||||
privacy-tags))
|
||||
tags-list)))))
|
||||
tags-list))))
|
||||
|
||||
#+end_src
|
||||
** org-privacy-strip
|
||||
@@ -299,7 +299,7 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (t) (string-trim '(#\:) t)) 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
|
||||
@@ -331,7 +331,10 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
|
||||
* Test Suite
|
||||
Verification of the structural manipulation for Org-mode files and their AST representation.
|
||||
#+begin_src lisp :tangle ../lisp/programming-org.lisp
|
||||
#+begin_src lisp :tangle ../tests/programming-org-tests.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))
|
||||
|
||||
@@ -43,9 +43,9 @@ The *Credentials Vault* provides secure in-memory storage for sensitive API keys
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Secret Wrappers (gateway-manager)
|
||||
** Secret Wrappers (gateway-messaging)
|
||||
|
||||
Thin wrappers that match the export names used by =gateway-manager=.
|
||||
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
|
||||
|
||||
@@ -104,7 +104,7 @@ Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (t) (string-trim '(#\Space) t))
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
@@ -167,23 +167,24 @@ Returns T if note was created, nil if it already exists."
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(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)))
|
||||
(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
|
||||
|
||||
@@ -290,10 +291,10 @@ Triggered by heartbeat events, runs Scribe and Gardener on alternating schedules
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-run (context)
|
||||
(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 context))
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
|
||||
@@ -142,11 +142,28 @@ 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-03T13:00:00
|
||||
;; REPL-VERIFIED: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
@@ -159,30 +176,61 @@ Creates the config directory tree if it does not exist.
|
||||
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)))
|
||||
(config-set env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(config-set 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
|
||||
|
||||
@@ -1,232 +0,0 @@
|
||||
#+TITLE: SKILL: Embedding Gateway (org-skill-embedding-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:memory:embeddings:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-embedding-gateway.lisp
|
||||
|
||||
* Overview
|
||||
|
||||
Provider-agnostic vector embedding gateway. Generates dense vectors for
|
||||
~memory-object~ entries via a pluggable backend, enabling semantic similarity
|
||||
search. Designed for thin harness: the core (core-context) knows how to USE
|
||||
vectors but not how to GENERATE them — that lives here.
|
||||
|
||||
Backends are configured via ~EMBEDDING_PROVIDER~:
|
||||
- ~:hashing~ (default) — FNV-1a hashing trick, no external dependencies
|
||||
- ~:ollama~ — POST /api/embeddings to a local Ollama instance
|
||||
|
||||
Newly ingested objects are queued for embedding via ~embed-queue-object~.
|
||||
The ~embed-all-pending~ function drains the queue on heartbeat ticks, with
|
||||
a store-wide scan as fallback for objects ingested before the skill loaded.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Embedding Queue
|
||||
|
||||
Pending object IDs to embed. Populated by ~embed-queue-object~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *embedding-queue* nil
|
||||
"List of object IDs pending embedding.")
|
||||
#+end_src
|
||||
|
||||
** Provider Selection
|
||||
|
||||
~*embedding-provider*~ tracks the active provider keyword. Set at load time
|
||||
from the ~EMBEDDING_PROVIDER~ env var.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *embedding-provider* :hashing
|
||||
"Active embedding provider: :hashing, :ollama, :openai.")
|
||||
#+end_src
|
||||
|
||||
** Text Tokenizer
|
||||
|
||||
Splits text into lowercase word tokens for the hashing trick.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embeddings-tokenize (text)
|
||||
"Split TEXT into lowercase word tokens, strip punctuation, discard short."
|
||||
(let ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]"
|
||||
(string-downcase (or text "")) " ")))
|
||||
(remove-if (lambda (w) (< (length w) 2))
|
||||
(uiop:split-string clean :separator '(#\Space #\Tab #\Newline)))))
|
||||
#+end_src
|
||||
|
||||
** Hashing Trick
|
||||
|
||||
FNV-1a hash to a fixed-dimension bucket. Produces dense ±1 vectors from
|
||||
vocabulary co-occurrence patterns without any training or external services.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embeddings-hash-word (word dim)
|
||||
"Hash WORD to an index in [0, DIM)."
|
||||
(let ((hash 2166136261))
|
||||
(loop for c across word
|
||||
do (setf hash (logxor hash (char-code c)))
|
||||
(setf hash (mod (* hash 16777619) #x100000000)))
|
||||
(mod hash dim)))
|
||||
#+end_src
|
||||
|
||||
** embeddings-hash-vector
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embeddings-hash-vector (text &key (dimensions 384))
|
||||
"Compute a hashing-trick vector for TEXT."
|
||||
(let* ((tokens (embeddings-tokenize text))
|
||||
(vec (make-array dimensions :initial-element 0.0d0 :element-type 'double-float)))
|
||||
(dolist (token tokens)
|
||||
(let* ((idx (embeddings-hash-word token dimensions))
|
||||
(sign (if (evenp (char-code (char token 0))) 1 -1)))
|
||||
(incf (aref vec idx) (coerce sign 'double-float))))
|
||||
(let ((norm (sqrt (loop for i below dimensions sum (expt (aref vec i) 2)))))
|
||||
(if (> norm 0.0d0)
|
||||
(loop for i below dimensions collect (/ (aref vec i) norm))
|
||||
(loop for i below dimensions collect 0.0d0)))))
|
||||
#+end_src
|
||||
|
||||
** Embedding Compute
|
||||
|
||||
Top-level embedding function. Tries the configured backend first, falls back
|
||||
to the hashing trick. Registered as ~*embedding-backend*~ for provider
|
||||
pluggability.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embeddings-compute (text &key (dimensions 384))
|
||||
"Compute embedding vector for TEXT.
|
||||
Tries *embedding-backend* first, falls back to hashing trick."
|
||||
(when *embedding-backend*
|
||||
(handler-case
|
||||
(let ((result (funcall *embedding-backend* text)))
|
||||
(when (and result (listp result) (> (length result) 0))
|
||||
(return-from embeddings-compute result)))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Backend failed (~a), fallback to hashing" c))))
|
||||
(embeddings-hash-vector text :dimensions dimensions))
|
||||
#+end_src
|
||||
|
||||
** Ollama Backend
|
||||
|
||||
Calls ~POST /api/embeddings~ on a local Ollama instance. Configurable via
|
||||
~OLLAMA_URL~ (default http://localhost:11434) and ~EMBEDDING_MODEL~ (default
|
||||
nomic-embed-text).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-ollama (text)
|
||||
"Generate embeddings via Ollama /api/embeddings."
|
||||
(let* ((url (or (uiop:getenv "OLLAMA_URL") "http://localhost:11434"))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||
(response (dex:post (format nil "~a/api/embeddings" url)
|
||||
:content (json:encode-json-to-string
|
||||
`((:model . ,model) (:prompt . ,text)))
|
||||
:headers '(("Content-Type" . "application/json")))))
|
||||
(when response
|
||||
(let* ((json (json:decode-json-from-string response))
|
||||
(embedding (cdr (assoc :embedding json))))
|
||||
(when embedding
|
||||
(coerce embedding 'list))))))
|
||||
#+end_src
|
||||
|
||||
** Queue Object
|
||||
|
||||
~embed-queue-object~ adds an object to the pending queue if it lacks a
|
||||
vector. Call from the perceive gate after ~ingest-ast~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embed-queue-object (obj)
|
||||
"Queue OBJ for embedding if it lacks a vector."
|
||||
(when (and obj (not (memory-object-vector obj)))
|
||||
(pushnew (memory-object-id obj) *embedding-queue* :test 'string=)))
|
||||
#+end_src
|
||||
|
||||
** Embed Single Object
|
||||
|
||||
Generates and stores a vector for a single memory object.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embed-object (obj)
|
||||
"Generate and store embedding vector for OBJ."
|
||||
(let* ((attrs (memory-object-attributes obj))
|
||||
(title (or (getf attrs :TITLE) ""))
|
||||
(text (or (memory-object-content obj) ""))
|
||||
(raw-tags (getf attrs :TAGS))
|
||||
(tag-list (if (listp raw-tags) raw-tags nil))
|
||||
(tags (if tag-list (format nil "~{~a~^ ~}" tag-list) ""))
|
||||
(combined (format nil "~a ~a ~a" title text tags))
|
||||
(vec (embeddings-compute combined)))
|
||||
(setf (memory-object-vector obj) vec)
|
||||
(log-message "EMBEDDING: Vector for ~a (~d dims)" (memory-object-id obj) (length vec))
|
||||
vec))
|
||||
#+end_src
|
||||
|
||||
** Batch Process
|
||||
|
||||
Drains the queue and (if queue was empty) scans the store for remaining
|
||||
objects without vectors. Returns count of newly embedded objects.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embed-all-pending ()
|
||||
"Process all pending embeddings. Returns count."
|
||||
(let ((count 0))
|
||||
;; Drain queue
|
||||
(let ((pending *embedding-queue*))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (id pending)
|
||||
(let ((obj (gethash id *memory-store*)))
|
||||
(when (and obj (not (memory-object-vector obj)))
|
||||
(handler-case
|
||||
(progn (embed-object obj) (incf count))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed ~a: ~a" id c)))))))
|
||||
;; Fallback: scan store for objects without vectors
|
||||
(when (= count 0)
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(unless (memory-object-vector obj)
|
||||
(handler-case
|
||||
(progn (embed-object obj) (incf count))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed ~a: ~a"
|
||||
(memory-object-id obj) c)))))
|
||||
*memory-store*))
|
||||
(when (> count 0)
|
||||
(log-message "EMBEDDING: Batch processed ~d objects" count))
|
||||
count))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
|
||||
Reads ~EMBEDDING_PROVIDER~ env var and configures the backend.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun embeddings-init (&key (provider *embedding-provider*))
|
||||
"Init embedding provider from EMBEDDING_PROVIDER env var."
|
||||
(let* ((env (uiop:getenv "EMBEDDING_PROVIDER"))
|
||||
(selected (or (and env (intern (string-upcase env) :keyword))
|
||||
provider)))
|
||||
(setf *embedding-provider* selected)
|
||||
(setf *embedding-backend*
|
||||
(case selected
|
||||
(:ollama #'embedding-backend-ollama)
|
||||
(t nil)))
|
||||
(log-message "EMBEDDING: Provider ~a, backend=~a" selected *embedding-backend*)
|
||||
selected))
|
||||
|
||||
(embeddings-init)
|
||||
#+end_src
|
||||
@@ -29,16 +29,16 @@ Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((t (memory-object-type obj))
|
||||
(let ((obj-type (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq t type-filter)))
|
||||
(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 t type-counts 0))
|
||||
(incf (gethash obj-type type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
|
||||
123
org/system-model-embedding.org
Normal file
123
org/system-model-embedding.org
Normal file
@@ -0,0 +1,123 @@
|
||||
#+TITLE: SKILL: Embedding Gateway (org-skill-embedding-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:system:embedding:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-embedding.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-embedding~ converts text into vector representations for semantic search and memory retrieval. It provides three backends:
|
||||
|
||||
- ~:local~ — any OpenAI-compatible ~/api/embeddings~ endpoint (Ollama, vLLM, etc.)
|
||||
- ~:openai~ — the OpenAI ~/v1/embeddings~ API with an API key
|
||||
- ~:hashing~ — a zero-dependency fallback that produces deterministic vectors from SHA-256 hashes. No server, no config, works offline.
|
||||
|
||||
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 ~:hashing~ — useful for bootstrapping with zero configuration and for deployments where embedding quality isn't critical. Switch to ~:local~ or ~:openai~ when you have an embedding server available.
|
||||
|
||||
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* :hashing
|
||||
"Active embedding provider: :hashing, :local, :openai.")
|
||||
|
||||
(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
|
||||
|
||||
** Hashing fallback
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-hashing (text)
|
||||
"Fallback: produces a deterministic vector from the text hash."
|
||||
(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))
|
||||
#+end_src
|
||||
|
||||
** Object embedding and queuing
|
||||
#+begin_src lisp
|
||||
(defun embed-object (text)
|
||||
"Embed a single text string using the active backend."
|
||||
(let* ((selected (or *embedding-provider* :hashing))
|
||||
(backend (case selected
|
||||
(:local #'embedding-backend-local)
|
||||
(:openai #'embedding-backend-openai)
|
||||
(t #'embedding-backend-hashing))))
|
||||
(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, batch-process all queued objects."
|
||||
(let ((batch (nreverse *embedding-queue*)))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (item batch)
|
||||
(handler-case
|
||||
(let ((text (if (stringp item) item (format nil "~a" item))))
|
||||
(embed-object text))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
|
||||
|
||||
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)
|
||||
#+end_src
|
||||
147
org/system-model-explorer.org
Normal file
147
org/system-model-explorer.org
Normal file
@@ -0,0 +1,147 @@
|
||||
#+TITLE: SKILL: Model Explorer (org-skill-model-explorer.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:explorer:discovery:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-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.
|
||||
|
||||
* 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 :tangle ../tests/model-explorer-tests.lisp
|
||||
;; REPL-verified: 2026-05-04
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-system-model-explorer-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:model-explorer-suite))
|
||||
|
||||
(in-package :passepartout-system-model-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
|
||||
"model-explorer-recommend should return 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
|
||||
"Each recommendation should have :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
|
||||
"Unknown slot should return fallback"
|
||||
(let ((recs (passepartout::model-explorer-recommend :unknown)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1))))
|
||||
|
||||
(fiveam:test model-explorer-fetch-openrouter-count
|
||||
"OpenRouter API should return at least 300 models"
|
||||
(let ((models (passepartout::model-explorer-fetch :openrouter)))
|
||||
(if models
|
||||
(fiveam:is (>= (length models) 300))
|
||||
(fiveam:skip "API unreachable"))))
|
||||
#+end_src
|
||||
@@ -1,27 +1,24 @@
|
||||
#+TITLE: SKILL: Unified LLM Backend (org-skill-unified-llm-backend.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:llm:backend:openai-compatible:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-provider.lisp
|
||||
#+FILETAGS: :skill:model:provider:llm:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-provider.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Unified LLM Backend provides a single OpenAI-compatible API client that works with any provider supporting the ~/v1/chat/completions~ endpoint. This covers local engines (Ollama, vLLM, LM Studio, llama.cpp) and cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM).
|
||||
~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.
|
||||
|
||||
The key design decision: **one client, many configurations**. Instead of having separate skills for each provider (org-skill-ollama, org-skill-openai, etc.), this single skill holds a configuration table mapping provider keywords to their base URL, API key env var, and default model. The same ~provider-openai-request~ function works for all of them.
|
||||
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 are registered automatically at boot based on which API keys are set in the environment. If OPENAI_API_KEY is set, OpenAI is available. If not, it's skipped silently.
|
||||
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.
|
||||
|
||||
Providers are registered automatically based on available environment variables.
|
||||
No separate skills per provider — just different base URLs and API keys.
|
||||
=*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.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Provider registry (~*provider-configs*~)
|
||||
The authoritative list of supported LLM providers and their configuration: base URL, env var for API key, and default model name.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Provider registry
|
||||
#+begin_src lisp
|
||||
(defparameter *provider-configs*
|
||||
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
|
||||
'((: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"))
|
||||
@@ -31,42 +28,42 @@ The authoritative list of supported LLM providers and their configuration: base
|
||||
(: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 (provider-config)
|
||||
Returns the config plist for a given provider keyword.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** 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 (provider-available-p)
|
||||
Returns T if a provider is configured — meaning it either has an API key set, or it is Ollama (always available locally).
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Availability check
|
||||
#+begin_src lisp
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Ollama is always considered available."
|
||||
"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 ((eq provider :ollama) t)
|
||||
(key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(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
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Unified request execution
|
||||
#+begin_src lisp
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(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 (eq provider :ollama)
|
||||
(format nil "http://~a/v1/chat/completions" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(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)))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
@@ -91,8 +88,7 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
#+end_src
|
||||
|
||||
** Dynamic Backend Registration
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
** Register all available providers
|
||||
#+begin_src lisp
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
@@ -103,10 +99,9 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(register-probabilistic-backend provider
|
||||
(lambda (prompt system-prompt &key model)
|
||||
(provider-openai-request prompt system-prompt :model model :provider provider)))))))
|
||||
|
||||
#+end_src
|
||||
** provider-cascade-initialize
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
|
||||
** Initialize cascade
|
||||
#+begin_src lisp
|
||||
(defun provider-cascade-initialize ()
|
||||
"Reads PROVIDER_CASCADE from env and sets *provider-cascade*."
|
||||
@@ -115,16 +110,47 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(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 *provider-configs*)))))
|
||||
#+end_src
|
||||
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
|
||||
(member (car e) '(:local)))
|
||||
*provider-configs*))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
** 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
|
||||
|
||||
(defskill :passepartout-gateway-provider
|
||||
** Skill registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-model-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
#+end_src
|
||||
@@ -171,7 +171,7 @@ Returns model name or :skip."
|
||||
(t *model-cascade-chat*)))
|
||||
(entry (model-cascade-find
|
||||
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
|
||||
(if entry (cdr entry) :skip)))))
|
||||
(if entry (cdr entry) nil)))))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
|
||||
39
org/system-model.org
Normal file
39
org/system-model.org
Normal file
@@ -0,0 +1,39 @@
|
||||
#+TITLE: SKILL: Model Dispatch (org-skill-model.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:dispatch:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model~ is the dispatcher. It sits between the reason pipeline and the provider backends registered in ~*probabilistic-backends*~. The reason pipeline calls ~model-request~ with a provider keyword and a model name; ~model-request~ looks up that provider's handler function, calls it, and returns the result.
|
||||
|
||||
This is intentionally thin. All the provider-specific logic (URL construction, API key headers, JSON parsing) lives in ~system-model-provider~. All the routing logic (which model for which task) lives in ~system-model-router~. This skill is the seam — it decouples "who to call" from "how to call them" and "why to call them."
|
||||
|
||||
When every provider fails (not registered, or all return errors), ~model-request~ returns an error plist with ~:status :error~. The reason pipeline's ~backend-cascade-call~ catches this and falls through to the next provider in the cascade. If no provider can serve the request, the cascade returns the "Neural Cascade Failure" signal.
|
||||
|
||||
~model-request~ replaces the old ~gateway-llm-request~ with the same contract but renamed for consistency with the ~system-model-*~ family.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Request execution
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun model-request (&key prompt system-prompt (provider :openrouter) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-model
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
83
passepartout
83
passepartout
@@ -83,7 +83,7 @@ setup_system() {
|
||||
|
||||
echo -e "${BLUE}=== Passepartout: Configure ===${NC}"
|
||||
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
|
||||
check_dependencies
|
||||
|
||||
@@ -98,41 +98,24 @@ setup_system() {
|
||||
|
||||
echo -e "${YELLOW}--- Deploying Engine to $PASSEPARTOUT_DATA_DIR ---${NC}"
|
||||
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
export INSTALL_DIR="$PASSEPARTOUT_DATA_DIR"
|
||||
|
||||
cp "$SCRIPT_DIR/org"/*.org "$PASSEPARTOUT_DATA_DIR/harness/"
|
||||
(cd "$PASSEPARTOUT_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 "$PASSEPARTOUT_DATA_DIR/harness"/*.org; do
|
||||
fname=$(basename "$f" .org)
|
||||
[ "$fname" = "manifest" ] && continue
|
||||
echo "Tangling harness/$fname.org..."
|
||||
(cd "$PASSEPARTOUT_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 "$PASSEPARTOUT_DATA_DIR/harness" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org
|
||||
|
||||
# Tangle all org files into lisp/
|
||||
for f in "$SCRIPT_DIR/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo "Tangling skills/$fname.org..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/skills/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/skills" && emacs -Q --batch \
|
||||
echo "Tangling $fname..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/org" && 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 "$PASSEPARTOUT_DATA_DIR/skills/$fname.org"
|
||||
done
|
||||
find "$PASSEPARTOUT_DATA_DIR/skills" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
[ -f "$PASSEPARTOUT_DATA_DIR/run-all-tests.lisp" ] && mv "$PASSEPARTOUT_DATA_DIR/run-all-tests.lisp" "$PASSEPARTOUT_DATA_DIR/harness/"
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org "$PASSEPARTOUT_DATA_DIR/skills"/*.org
|
||||
# Move test files to tests/ directory
|
||||
find "$PASSEPARTOUT_DATA_DIR/lisp" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
|
||||
ln -sf "$SCRIPT_DIR/passepartout.sh" "$PASSEPARTOUT_BIN_DIR/passepartout"
|
||||
ln -sf "$SCRIPT_DIR/passepartout" "$PASSEPARTOUT_BIN_DIR/passepartout"
|
||||
|
||||
if [ "$WITH_FIREWALL" = true ]; then
|
||||
case $(detect_distro) in
|
||||
@@ -160,38 +143,23 @@ doctor_repair() {
|
||||
echo -e "${BLUE}=== Passepartout: Repair Mode ===${NC}"
|
||||
check_dependencies
|
||||
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
for f in "$SCRIPT_DIR/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking harness/$fname..."
|
||||
echo " Checking $fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/harness/${fname}.lisp\")" \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/lisp/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
(cd "$PASSEPARTOUT_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/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking skill/$fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/skills/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/skills/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/skills" && emacs -Q --batch \
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/org" && 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 "$PASSEPARTOUT_DATA_DIR/skills/$fname.org"
|
||||
fi
|
||||
done
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org "$PASSEPARTOUT_DATA_DIR/skills"/*.org 2>/dev/null || true
|
||||
find "$PASSEPARTOUT_DATA_DIR/lisp" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
echo -e "${GREEN}--- Repair Complete ---${NC}"
|
||||
}
|
||||
|
||||
@@ -382,7 +350,8 @@ case "$COMMAND" in
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(ql:quickload :passepartout)" \
|
||||
--eval "(load (format nil \"~alisp/system-model-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-embedding-gateway.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-model-embedding.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-model-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval '(passepartout:main)' \
|
||||
> "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 &
|
||||
echo "Waiting for port 9105..."
|
||||
@@ -396,14 +365,20 @@ case "$COMMAND" in
|
||||
;;
|
||||
tui)
|
||||
check_dependencies
|
||||
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
|
||||
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
|
||||
exec sbcl \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval '(ql:quickload :passepartout/tui)' \
|
||||
--eval '(passepartout.gateway-tui:main)'
|
||||
--eval '(declaim (optimize (debug 3) (speed 0) (safety 3)))' \
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout/tui :force t)' \
|
||||
--eval '(in-package :passepartout)' \
|
||||
--eval "(load (format nil \"~alisp/system-model-provider.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-model-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.gateway-tui:tui-main))'
|
||||
;;
|
||||
gateway)
|
||||
SUBCMD=$1; PLATFORM=$2; TOKEN=$3
|
||||
@@ -415,7 +390,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval '(funcall (find-symbol "GATEWAY-LIST-PRINT" (find-package "OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER")))'
|
||||
--eval '(funcall (find-symbol "MESSAGING-LIST-PRINT" (find-package "OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING")))'
|
||||
;;
|
||||
link)
|
||||
[ -z "$PLATFORM" ] || [ -z "$TOKEN" ] && echo "Usage: passepartout gateway link <platform> <token>" && exit 1
|
||||
@@ -424,7 +399,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-LINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\" \"$TOKEN\")"
|
||||
--eval "(funcall (find-symbol \"MESSAGING-LINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING\")) \"$PLATFORM\" \"$TOKEN\")"
|
||||
;;
|
||||
unlink)
|
||||
[ -z "$PLATFORM" ] && echo "Usage: passepartout gateway unlink <platform>" && exit 1
|
||||
@@ -433,7 +408,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-UNLINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\")"
|
||||
--eval "(funcall (find-symbol \"MESSAGING-UNLINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING\")) \"$PLATFORM\")"
|
||||
;;
|
||||
*) echo "Usage: passepartout gateway {list|link|unlink}"; exit 1 ;;
|
||||
esac
|
||||
|
||||
@@ -30,8 +30,12 @@
|
||||
(:file "tests/tui-tests")
|
||||
(:file "tests/utils-org-tests")
|
||||
(:file "tests/utils-lisp-tests")
|
||||
(:file "tests/llm-gateway-tests")))
|
||||
(:file "tests/llm-gateway-tests")
|
||||
(:file "tests/model-explorer-tests")))
|
||||
|
||||
(defsystem :passepartout/tui
|
||||
:depends-on (:passepartout :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "lisp/gateway-tui")))
|
||||
:serial t
|
||||
:components ((:file "lisp/gateway-tui-model")
|
||||
(:file "lisp/gateway-tui-view")
|
||||
(:file "lisp/gateway-tui-main")))
|
||||
|
||||
@@ -44,7 +44,7 @@ for orgfile in $CHANGED; do
|
||||
# Skip files that depend on external libraries not loaded in the daemon
|
||||
BASENAME=$(basename "$orgfile")
|
||||
case "$BASENAME" in
|
||||
gateway-tui.org)
|
||||
gateway-tui.org|gateway-tui-model.org|gateway-tui-view.org|gateway-tui-main.org)
|
||||
echo "SKIP: $orgfile — external dependency (croatoan)" >&2
|
||||
continue
|
||||
;;
|
||||
|
||||
Reference in New Issue
Block a user