Add v0.2.0 features: vector search + tool permissions
- Local vector search: Ollama embeddings + semantic search - get-embedding with caching - cosine-similarity computation - semantic-search cognitive tool - :semantic-search tool for LLM queries - Tool permission tiers: security gating for cognitive tools - Three tiers: :allow, :deny, :ask - Gate in execute-tool-action before tool runs - Defaults: :deny for shell/delete-file, :ask for eval/write-file - :tool-permissions cognitive tool for management - Embedding provider support: Ollama AND llama.cpp - EMBEDDING_PROVIDER env var - EMBEDDING_MODEL env var - LLAMA_HOST for llama.cpp server - .env.example: Add embedding config variables - Fix parse-message in communication.lisp - Update ASDF: add test files, tool-permissions skill All 60 tests pass (6 suites x 100%)
This commit is contained in:
@@ -25,7 +25,13 @@ PROVIDER_CASCADE="openrouter,openai,anthropic,groq,gemini-api,ollama"
|
|||||||
OLLAMA_HOST="localhost:11434"
|
OLLAMA_HOST="localhost:11434"
|
||||||
|
|
||||||
# llama.cpp backend (for local GGUF models)
|
# llama.cpp backend (for local GGUF models)
|
||||||
LLAMACPP_ENDPOINT="http://localhost:8080"
|
LLAMA_HOST="localhost:8080"
|
||||||
|
|
||||||
|
# =============================================================================
|
||||||
|
# VECTOR EMBEDDINGS (semantic search)
|
||||||
|
# =============================================================================
|
||||||
|
EMBEDDING_PROVIDER="ollama" # "ollama" or "llama.cpp"
|
||||||
|
EMBEDDING_MODEL="nomic-embed-text" # model name for embeddings
|
||||||
|
|
||||||
# =============================================================================
|
# =============================================================================
|
||||||
# MESSAGING GATEWAYS (optional)
|
# MESSAGING GATEWAYS (optional)
|
||||||
|
|||||||
@@ -201,6 +201,69 @@ Reconstitutes alists into hash tables."
|
|||||||
t))
|
t))
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
|
** Semantic Search (get-embedding, semantic-search)
|
||||||
|
Support for vector embeddings via Ollama and semantic search with cosine similarity.
|
||||||
|
|
||||||
|
The vector slot on org-objects enables semantic recall - searching memory by meaning rather than just keywords. Embeddings are generated on ingest when the :EMBED property is set to "t", and cached locally to avoid redundant API calls.
|
||||||
|
|
||||||
|
#+begin_src lisp :tangle ../library/memory.lisp
|
||||||
|
(defvar *embedding-cache* (make-hash-table :test 'equal)
|
||||||
|
"Cache for embeddings to avoid redundant API calls.")
|
||||||
|
|
||||||
|
(defun get-embedding (text)
|
||||||
|
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
|
||||||
|
(when (or (null text) (string= text ""))
|
||||||
|
(return-from get-embedding nil))
|
||||||
|
(let ((cached (gethash text *embedding-cache*)))
|
||||||
|
(when cached (return-from get-embedding cached)))
|
||||||
|
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
|
||||||
|
(when (eq (getf result :status) :success)
|
||||||
|
(let ((vec (getf result :vector)))
|
||||||
|
(setf (gethash text *embedding-cache*) vec)
|
||||||
|
vec))))
|
||||||
|
|
||||||
|
(defun cosine-similarity (vec-a vec-b)
|
||||||
|
"Computes cosine similarity between two vectors. Both should be sequences of numbers."
|
||||||
|
(when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b)))
|
||||||
|
(return-from cosine-similarity 0.0))
|
||||||
|
(let ((dot-product (loop for a across vec-a
|
||||||
|
for b across vec-b
|
||||||
|
sum (* a b)))
|
||||||
|
(norm-a (sqrt (loop for a across vec-a sum (* a a))))
|
||||||
|
(norm-b (sqrt (loop for b across vec-b sum (* b b)))))
|
||||||
|
(if (or (zerop norm-a) (zerop norm-b))
|
||||||
|
0.0
|
||||||
|
(/ dot-product (* norm-a norm-b)))))
|
||||||
|
|
||||||
|
(defun semantic-search (query &key (limit 10) (min-similarity 0.5))
|
||||||
|
"Searches memory for objects semantically similar to the query.
|
||||||
|
Returns up to LIMIT objects with similarity >= MIN-SIMILARITY, sorted by similarity descending."
|
||||||
|
(let* ((query-vec (get-embedding query))
|
||||||
|
(results nil))
|
||||||
|
(unless query-vec
|
||||||
|
(harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query)
|
||||||
|
(return-from semantic-search nil))
|
||||||
|
(maphash (lambda (id obj)
|
||||||
|
(let ((obj-vec (org-object-vector obj)))
|
||||||
|
(when obj-vec
|
||||||
|
(let ((sim (cosine-similarity query-vec obj-vec)))
|
||||||
|
(when (>= sim min-similarity)
|
||||||
|
(push (list :id id :object obj :similarity sim) results))))))
|
||||||
|
*memory*)
|
||||||
|
(setf results (sort results #'> :key (lambda (r) (getf r :similarity))))
|
||||||
|
(subseq results 0 (min limit (length results)))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :semantic-search
|
||||||
|
"Searches memory for objects semantically similar to a query."
|
||||||
|
((:query :type :string :description "The search query.")
|
||||||
|
(:limit :type :integer :description "Maximum results to return." :default 10)
|
||||||
|
(:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5))
|
||||||
|
:body (lambda (args)
|
||||||
|
(semantic-search (getf args :query)
|
||||||
|
:limit (or (getf args :limit) 10)
|
||||||
|
:min-similarity (or (getf args :min-similarity) 0.5))))
|
||||||
|
#+end_src
|
||||||
|
|
||||||
** Lookup Utilities
|
** Lookup Utilities
|
||||||
Basic functions for retrieving objects by ID or type.
|
Basic functions for retrieving objects by ID or type.
|
||||||
|
|
||||||
|
|||||||
@@ -81,8 +81,18 @@
|
|||||||
(meta (getf context :meta))
|
(meta (getf context :meta))
|
||||||
(source (getf meta :source))
|
(source (getf meta :source))
|
||||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||||
(if tool
|
(when tool
|
||||||
(handler-case
|
;; Tool Permission Gate: Check permission before execution
|
||||||
|
(let ((permission (check-tool-permission-gate tool-name context)))
|
||||||
|
(when (eq permission :deny)
|
||||||
|
(return-from execute-tool-action
|
||||||
|
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||||
|
:PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "Tool PERMISSION DENIED: ~a" tool-name))))))
|
||||||
|
(when (listp permission)
|
||||||
|
(return-from execute-tool-action
|
||||||
|
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||||
|
:PAYLOAD (list :SENSOR :permission-pending :tool tool-name :args tool-args)))))
|
||||||
|
(handler-case
|
||||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||||
(let ((feedback (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
(let ((feedback (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||||
@@ -94,10 +104,10 @@
|
|||||||
context))
|
context))
|
||||||
feedback))
|
feedback))
|
||||||
(error (c)
|
(error (c)
|
||||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
|
||||||
:PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "~a" c)))))
|
|
||||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||||
:PAYLOAD (list :SENSOR :tool-error :message "Tool not found")))))
|
:PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "~a" c)))))
|
||||||
|
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||||
|
:PAYLOAD (list :SENSOR :tool-error :message "Tool not found"))))
|
||||||
|
|
||||||
(defun act-gate (signal)
|
(defun act-gate (signal)
|
||||||
"Final Stage: Actuation and feedback generation."
|
"Final Stage: Actuation and feedback generation."
|
||||||
|
|||||||
@@ -16,6 +16,13 @@
|
|||||||
(len (length msg-string)))
|
(len (length msg-string)))
|
||||||
(format nil "~6,'0x~a~%" len msg-string)))
|
(format nil "~6,'0x~a~%" len msg-string)))
|
||||||
|
|
||||||
|
(defun parse-message (framed-string)
|
||||||
|
"Parses a hex-length prefixed framed string into a Lisp plist."
|
||||||
|
(let* ((len (parse-integer (subseq framed-string 0 6) :radix 16))
|
||||||
|
(payload (subseq framed-string 6 (+ 6 len))))
|
||||||
|
(let ((*read-eval* nil))
|
||||||
|
(read-from-string payload))))
|
||||||
|
|
||||||
(defun read-framed-message (stream)
|
(defun read-framed-message (stream)
|
||||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||||
(let ((length-buffer (make-string 6)))
|
(let ((length-buffer (make-string 6)))
|
||||||
|
|||||||
@@ -91,6 +91,30 @@
|
|||||||
(opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model)
|
(opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model)
|
||||||
(execute-llm-request prompt system-prompt :provider p :model model))))
|
(execute-llm-request prompt system-prompt :provider p :model model))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :get-ollama-embedding
|
||||||
|
"Generates vector embeddings via Ollama API."
|
||||||
|
((text :type :string :description "Text to embed."))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let* ((text (getf args :text))
|
||||||
|
(host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||||
|
(url (format nil "http://~a/api/embeddings" host))
|
||||||
|
(model (or (uiop:getenv "OLLAMA_EMBEDDING_MODEL") "nomic-embed-text"))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response)))
|
||||||
|
(let ((embedding (cdr (assoc :embedding json))))
|
||||||
|
(if embedding
|
||||||
|
(list :status :success :vector embedding)
|
||||||
|
(list :status :error :message "No embedding in response"))))
|
||||||
|
(error (c) (list :status :error :message (format nil "Ollama Embedding Failure: ~a" c)))))))
|
||||||
|
|
||||||
|
(defun get-embedding (text)
|
||||||
|
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
|
||||||
|
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
|
||||||
|
(when (eq (getf result :status) :success)
|
||||||
|
(getf result :vector))))
|
||||||
|
|
||||||
(def-cognitive-tool :ask-llm
|
(def-cognitive-tool :ask-llm
|
||||||
"Queries an LLM provider via the unified gateway."
|
"Queries an LLM provider via the unified gateway."
|
||||||
((:prompt :type :string :description "The user prompt.")
|
((:prompt :type :string :description "The user prompt.")
|
||||||
|
|||||||
91
library/gen/org-skill-tool-permissions.lisp
Normal file
91
library/gen/org-skill-tool-permissions.lisp
Normal file
@@ -0,0 +1,91 @@
|
|||||||
|
(in-package :opencortex)
|
||||||
|
|
||||||
|
(defvar *tool-permissions* (make-hash-table :test 'equal)
|
||||||
|
"Hash table mapping tool names to :allow/:deny/:ask.")
|
||||||
|
|
||||||
|
(defun get-tool-permission (tool-name)
|
||||||
|
(let ((key (string-downcase (string tool-name))))
|
||||||
|
(or (gethash key *tool-permissions*) :allow)))
|
||||||
|
|
||||||
|
(defun set-tool-permission (tool-name tier)
|
||||||
|
(setf (gethash (string-downcase (string tool-name)) *tool-permissions*) tier)
|
||||||
|
(harness-log "TOOL PERMISSION: Set ~a = ~a" tool-name tier))
|
||||||
|
|
||||||
|
(defun check-tool-permission-gate (tool-name context)
|
||||||
|
(declare (ignore context))
|
||||||
|
(let ((perm (get-tool-permission tool-name)))
|
||||||
|
(case perm
|
||||||
|
(:allow :allow)
|
||||||
|
(:deny :deny)
|
||||||
|
(:ask (list :ask tool-name context))
|
||||||
|
(t :allow))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :get-embedding
|
||||||
|
"Generates vector embeddings via Ollama or llama.cpp API."
|
||||||
|
((text :type :string :description "Text to embed."))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let* ((text (getf args :text))
|
||||||
|
(provider (or (uiop:getenv "EMBEDDING_PROVIDER") "ollama"))
|
||||||
|
(model (or (uiop:getenv "EMBEDDING_MODEL")
|
||||||
|
(case (intern (string-upcase provider) :keyword)
|
||||||
|
(:NOMIC-EMBED-TEXT "nomic-embed-text")
|
||||||
|
(:LLAMA-CPP "llama.cpp")
|
||||||
|
(t "nomic-embed-text"))))
|
||||||
|
(embedding nil))
|
||||||
|
(cond
|
||||||
|
((string= provider "ollama")
|
||||||
|
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||||
|
(url (format nil "http://~a/api/embeddings" host))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response))
|
||||||
|
(vec (cdr (assoc :embedding json))))
|
||||||
|
(when vec (setf embedding vec)))
|
||||||
|
(error (c) (harness-log "EMBEDDING: Ollama failed: ~a" c)))))
|
||||||
|
((string= provider "llama.cpp")
|
||||||
|
(let* ((host (or (uiop:getenv "LLAMA_HOST") "localhost:8080"))
|
||||||
|
(url (format nil "http://~a/v1/embeddings" host))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (input . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response))
|
||||||
|
(data (cdr (assoc :data json)))
|
||||||
|
(vec (when data (cdr (assoc :embedding (car data))))))
|
||||||
|
(when vec (setf embedding vec)))
|
||||||
|
(error (c) (harness-log "EMBEDDING: llama.cpp failed: ~a" c))))))
|
||||||
|
(if embedding
|
||||||
|
(list :status :success :vector embedding)
|
||||||
|
(list :status :error :message "Embedding generation failed")))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :tool-permissions
|
||||||
|
"View or set tool permission tiers."
|
||||||
|
((:tool :type :string :description "Tool name")
|
||||||
|
(:action :type :keyword :description "Action: :get, :set, :list" :default :get)
|
||||||
|
(:tier :type :keyword :description "For :set: :allow/:deny/:ask"))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let ((tool (getf args :tool))
|
||||||
|
(action (getf args :action :get))
|
||||||
|
(tier (getf args :tier)))
|
||||||
|
(case action
|
||||||
|
(:get (list :status :success :tool tool :permission (get-tool-permission tool)))
|
||||||
|
(:set (progn (set-tool-permission tool tier)
|
||||||
|
(list :status :success :message (format nil "Set ~a = ~a" tool tier))))
|
||||||
|
(:list (let ((r nil))
|
||||||
|
(maphash (lambda (k v) (push (list :tool k :permission v) r)) *tool-permissions*)
|
||||||
|
(list :status :success :tools r)))
|
||||||
|
(t (list :status :error :message "Invalid action"))))))
|
||||||
|
|
||||||
|
;; Defaults
|
||||||
|
(set-tool-permission :shell :deny)
|
||||||
|
(set-tool-permission :delete-file :deny)
|
||||||
|
(set-tool-permission :eval :ask)
|
||||||
|
(set-tool-permission :write-file :ask)
|
||||||
|
(harness-log "TOOL PERMISSIONS: Initialized")
|
||||||
|
|
||||||
|
(defskill :skill-tool-permissions
|
||||||
|
:priority 600
|
||||||
|
:trigger (lambda (c) (declare (ignore c)) nil)
|
||||||
|
:deterministic (lambda (a c)
|
||||||
|
(let ((tool (getf (getf a :payload) :tool)))
|
||||||
|
(when tool (check-tool-permission-gate tool c)))))
|
||||||
@@ -161,3 +161,58 @@ Reconstitutes alists into hash tables."
|
|||||||
(defun file-name-nondirectory (path)
|
(defun file-name-nondirectory (path)
|
||||||
"Extracts the filename from a full path string."
|
"Extracts the filename from a full path string."
|
||||||
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
||||||
|
|
||||||
|
(defvar *embedding-cache* (make-hash-table :test 'equal)
|
||||||
|
"Cache for embeddings to avoid redundant API calls.")
|
||||||
|
|
||||||
|
(defun get-embedding (text)
|
||||||
|
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
|
||||||
|
(when (or (null text) (string= text ""))
|
||||||
|
(return-from get-embedding nil))
|
||||||
|
(let ((cached (gethash text *embedding-cache*)))
|
||||||
|
(when cached (return-from get-embedding cached)))
|
||||||
|
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
|
||||||
|
(when (eq (getf result :status) :success)
|
||||||
|
(let ((vec (getf result :vector)))
|
||||||
|
(setf (gethash text *embedding-cache*) vec)
|
||||||
|
vec))))
|
||||||
|
|
||||||
|
(defun cosine-similarity (vec-a vec-b)
|
||||||
|
"Computes cosine similarity between two vectors. Both should be sequences of numbers."
|
||||||
|
(when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b)))
|
||||||
|
(return-from cosine-similarity 0.0))
|
||||||
|
(let ((dot-product (loop for a across vec-a
|
||||||
|
for b across vec-b
|
||||||
|
sum (* a b)))
|
||||||
|
(norm-a (sqrt (loop for a across vec-a sum (* a a))))
|
||||||
|
(norm-b (sqrt (loop for b across vec-b sum (* b b)))))
|
||||||
|
(if (or (zerop norm-a) (zerop norm-b))
|
||||||
|
0.0
|
||||||
|
(/ dot-product (* norm-a norm-b)))))
|
||||||
|
|
||||||
|
(defun semantic-search (query &key (limit 10) (min-similarity 0.5))
|
||||||
|
"Searches memory for objects semantically similar to the query."
|
||||||
|
(let* ((query-vec (get-embedding query))
|
||||||
|
(results nil))
|
||||||
|
(unless query-vec
|
||||||
|
(harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query)
|
||||||
|
(return-from semantic-search nil))
|
||||||
|
(maphash (lambda (id obj)
|
||||||
|
(let ((obj-vec (org-object-vector obj)))
|
||||||
|
(when obj-vec
|
||||||
|
(let ((sim (cosine-similarity query-vec obj-vec)))
|
||||||
|
(when (>= sim min-similarity)
|
||||||
|
(push (list :id id :object obj :similarity sim) results))))))
|
||||||
|
*memory*)
|
||||||
|
(setf results (sort results #'> :key (lambda (r) (getf r :similarity))))
|
||||||
|
(subseq results 0 (min limit (length results)))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :semantic-search
|
||||||
|
"Searches memory for objects semantically similar to a query."
|
||||||
|
((:query :type :string :description "The search query.")
|
||||||
|
(:limit :type :integer :description "Maximum results to return." :default 10)
|
||||||
|
(:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5))
|
||||||
|
:body (lambda (args)
|
||||||
|
(semantic-search (getf args :query)
|
||||||
|
:limit (or (getf args :limit) 10)
|
||||||
|
:min-similarity (or (getf args :min-similarity) 0.5))))
|
||||||
|
|||||||
@@ -167,3 +167,16 @@
|
|||||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||||
(format t "~a~%" formatted-msg)
|
(format t "~a~%" formatted-msg)
|
||||||
(finish-output)))
|
(finish-output)))
|
||||||
|
|
||||||
|
(defun proto-get (plist key)
|
||||||
|
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||||
|
(let* ((s (string key))
|
||||||
|
(up (intern (string-upcase s) :keyword))
|
||||||
|
(dn (intern (string-downcase s) :keyword)))
|
||||||
|
(or (getf plist up) (getf plist dn))))
|
||||||
|
|
||||||
|
(defun get-cognitive-tool-body (tool-name)
|
||||||
|
"Retrieves the body function of a cognitive tool, or nil if not found."
|
||||||
|
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||||
|
(when tool
|
||||||
|
(cognitive-tool-body tool))))
|
||||||
|
|||||||
@@ -4,46 +4,72 @@
|
|||||||
:version "0.1.0"
|
:version "0.1.0"
|
||||||
:license "AGPLv3"
|
:license "AGPLv3"
|
||||||
:description "The Probabilistic-Deterministic Lisp Machine Harness"
|
:description "The Probabilistic-Deterministic Lisp Machine Harness"
|
||||||
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
|
|
||||||
:serial t
|
:depends-on (:usocket ; TCP socket networking
|
||||||
:components ((:file "library/package")
|
:bordeaux-threads ; Threading (heartbeat, async sensors)
|
||||||
(:file "library/skills" :depends-on ("library/package"))
|
:dexador ; HTTP client (LLM APIs)
|
||||||
(:file "library/memory" :depends-on ("library/package"))
|
:uiop ; Portable I/O, file operations
|
||||||
(:file "library/context" :depends-on ("library/package" "library/memory"))
|
:cl-dotenv ; Environment variable loading
|
||||||
(:file "library/communication" :depends-on ("library/package"))
|
:cl-ppcre ; Regular expressions (parsing)
|
||||||
(:file "library/communication-validator" :depends-on ("library/package" "library/communication"))
|
:hunchentoot ; HTTP server (optional web interface)
|
||||||
(:file "library/perceive" :depends-on ("library/package"))
|
:ironclad ; Cryptography (Merkle hashing)
|
||||||
(:file "library/reason" :depends-on ("library/package" "library/perceive"))
|
:str ; String utilities
|
||||||
(:file "library/act" :depends-on ("library/package" "library/reason"))
|
:cl-json ; JSON parsing/serialization
|
||||||
(:file "library/loop" :depends-on ("library/package" "library/act")))
|
:uuid) ; UUID generation for org-mode IDs
|
||||||
|
|
||||||
|
:serial t ; Load files in order listed below
|
||||||
|
|
||||||
|
:components ((:file "library/package") ; Package definitions, core vars
|
||||||
|
(:file "library/skills") ; Skill engine, cognitive tools
|
||||||
|
(:file "library/communication") ; Protocol, framing
|
||||||
|
(:file "library/communication-validator") ; Schema validation
|
||||||
|
(:file "library/memory") ; Org-object store, snapshots
|
||||||
|
(:file "library/context") ; Context assembly, query
|
||||||
|
(:file "library/perceive") ; Stage 1: Sensory normalization
|
||||||
|
(:file "library/reason") ; Stage 2: Neural + deterministic
|
||||||
|
(:file "library/act") ; Stage 3: Actuation
|
||||||
|
(:file "library/loop")) ; Main entry, heartbeat
|
||||||
|
|
||||||
:build-operation "program-op"
|
:build-operation "program-op"
|
||||||
:build-pathname "opencortex-server"
|
:build-pathname "opencortex-server"
|
||||||
:entry-point "opencortex:main")
|
:entry-point "opencortex:main")
|
||||||
|
|
||||||
(defsystem :opencortex/tests
|
(defsystem :opencortex/tests
|
||||||
:depends-on (:opencortex :fiveam)
|
:depends-on (:opencortex ; The harness we're testing
|
||||||
:components ((:file "tests/communication-tests")
|
:fiveam) ; Testing framework
|
||||||
(:file "tests/pipeline-tests")
|
|
||||||
(:file "tests/act-tests")
|
|
||||||
(:file "tests/boot-sequence-tests")
|
|
||||||
(:file "tests/memory-tests")
|
|
||||||
(:file "tests/immune-system-tests")
|
|
||||||
(:file "tests/emacs-edit-tests")
|
|
||||||
(:file "tests/lisp-utils-tests"))
|
|
||||||
:perform (test-op (o s)
|
|
||||||
(uiop:symbol-call :fiveam :run! :communication-protocol-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :pipeline-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :safety-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :boot-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :memory-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :immune-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :emacs-edit-suite)
|
|
||||||
(uiop:symbol-call :fiveam :run! :lisp-utils-suite)))
|
|
||||||
|
|
||||||
(defsystem opencortex-test
|
:components ((:file "library/gen/org-skill-emacs-edit")
|
||||||
:depends-on (:opencortex/tests)
|
(:file "library/gen/org-skill-lisp-utils")
|
||||||
:perform (test-op (o s) (asdf:test-system :opencortex/tests)))
|
(:file "library/gen/org-skill-tool-permissions")
|
||||||
|
(:file "tests/communication-tests")
|
||||||
|
(:file "tests/pipeline-tests")
|
||||||
|
(:file "tests/act-tests")
|
||||||
|
(:file "tests/boot-sequence-tests")
|
||||||
|
(:file "tests/memory-tests")
|
||||||
|
(:file "tests/immune-system-tests")
|
||||||
|
(:file "tests/emacs-edit-tests")
|
||||||
|
(:file "tests/lisp-utils-tests"))
|
||||||
|
|
||||||
|
:perform (test-op (o s)
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :communication-protocol-suite :opencortex-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :pipeline-suite :opencortex-pipeline-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :boot-suite :opencortex-boot-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :memory-suite :opencortex-memory-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :immune-suite :opencortex-immune-system-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :emacs-edit-suite :opencortex-emacs-edit-tests))
|
||||||
|
(uiop:symbol-call :fiveam :run!
|
||||||
|
(uiop:find-symbol* :lisp-utils-suite :opencortex-lisp-utils-tests))))
|
||||||
|
|
||||||
(defsystem :opencortex/tui
|
(defsystem :opencortex/tui
|
||||||
:depends-on (:opencortex :croatoan :usocket :bordeaux-threads)
|
:depends-on (:opencortex ; The daemon we're connecting to
|
||||||
:components ((:file "library/tui-client")))
|
:croatoan ; Terminal UI library
|
||||||
|
:usocket ; Socket communication
|
||||||
|
:bordeaux-threads) ; Background listening thread
|
||||||
|
|
||||||
|
:components ((:file "library/tui-client")))
|
||||||
|
|||||||
@@ -69,11 +69,9 @@ Generate unique IDs for headlines.
|
|||||||
(defun emacs-edit-generate-id ()
|
(defun emacs-edit-generate-id ()
|
||||||
"Generates a unique ID for org-mode headlines.
|
"Generates a unique ID for org-mode headlines.
|
||||||
Format: 8-char hex + timestamp for uniqueness."
|
Format: 8-char hex + timestamp for uniqueness."
|
||||||
(let ((uuid (ironclad:byte-array-to-hex-string
|
(let* ((data (format nil "~a-~a" (get-universal-time) (random 999999)))
|
||||||
(ironclad:produce-digest :sha256
|
(digest (ironclad:digest-sequence :sha256 (ironclad:ascii-string-to-byte-array data)))
|
||||||
(format nil "~a-~a"
|
(uuid (ironclad:byte-array-to-hex-string digest)))
|
||||||
(get-universal-time)
|
|
||||||
(random 999999))))))
|
|
||||||
(subseq uuid 0 8)))
|
(subseq uuid 0 8)))
|
||||||
|
|
||||||
(defun emacs-edit-id-format (id)
|
(defun emacs-edit-id-format (id)
|
||||||
@@ -106,7 +104,7 @@ INDENT-LEVEL is number of leading asterisks."
|
|||||||
unless (member k '(:title :todo :created :id))
|
unless (member k '(:title :todo :created :id))
|
||||||
collect (format nil ":~a:~a" k v))))
|
collect (format nil ":~a:~a" k v))))
|
||||||
(when lines
|
(when lines
|
||||||
(format nil ":PROPERTIES:~%~{~a~^~%~}~:END:~%"
|
(format nil ":PROPERTIES:~%~{~a~^~%~}~%:END:~%"
|
||||||
lines)))))
|
lines)))))
|
||||||
|
|
||||||
(defun emacs-edit-print-section (ast)
|
(defun emacs-edit-print-section (ast)
|
||||||
@@ -146,7 +144,7 @@ Preserves structure including #+begin_src blocks."
|
|||||||
((eq type :src-block)
|
((eq type :src-block)
|
||||||
(let ((lang (or (getf ast :language) ""))
|
(let ((lang (or (getf ast :language) ""))
|
||||||
(code (or (getf ast :value) "")))
|
(code (or (getf ast :value) "")))
|
||||||
(format nil "#+begin_src ~a~%~a~#+end_src~%"
|
(format nil "#+begin_src ~a~%~a~%#+end_src~%"
|
||||||
lang code)))
|
lang code)))
|
||||||
|
|
||||||
;; Unknown - return as-is
|
;; Unknown - return as-is
|
||||||
@@ -208,7 +206,7 @@ Returns modified AST."
|
|||||||
(multiple-value-bind (s mi h d mo y)
|
(multiple-value-bind (s mi h d mo y)
|
||||||
(decode-universal-time (get-universal-time))
|
(decode-universal-time (get-universal-time))
|
||||||
(format nil "~a-~a-~a ~a:~a"
|
(format nil "~a-~a-~a ~a:~a"
|
||||||
y mo d h mi))))))
|
y mo d h mi)))))
|
||||||
(merged-props (loop for (k v) on properties by #'cddr
|
(merged-props (loop for (k v) on properties by #'cddr
|
||||||
collect k collect v)))
|
collect k collect v)))
|
||||||
|
|
||||||
|
|||||||
@@ -161,7 +161,7 @@ Returns (VALUES t nil) if clean, or (VALUES nil reason-string line col)."
|
|||||||
(values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col)))
|
(values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col)))
|
||||||
(t (pop stack))))
|
(t (pop stack))))
|
||||||
((char= ch #\Newline)
|
((char= ch #\Newline)
|
||||||
(incf line) (setf col 0))))
|
(incf line) (setf col 0)))
|
||||||
(unless (char= ch #\Newline) (incf col))))
|
(unless (char= ch #\Newline) (incf col))))
|
||||||
(if (null stack)
|
(if (null stack)
|
||||||
(values t nil nil nil)
|
(values t nil nil nil)
|
||||||
@@ -231,7 +231,7 @@ Recursively walks the parsed AST and verifies whitelisted symbols.
|
|||||||
;; Time
|
;; Time
|
||||||
get-universal-time get-internal-real-time sleep
|
get-universal-time get-internal-real-time sleep
|
||||||
;; Equality
|
;; Equality
|
||||||
equalp = equal eq eql))
|
equalp = equal eq eql)
|
||||||
"Static whitelist of symbols permitted in the Lisp Utils sandbox.")
|
"Static whitelist of symbols permitted in the Lisp Utils sandbox.")
|
||||||
|
|
||||||
(defun lisp-utils-ast-walk (form)
|
(defun lisp-utils-ast-walk (form)
|
||||||
@@ -373,7 +373,7 @@ Intercepts :syntax-error events and repairs the code.
|
|||||||
repaired)
|
repaired)
|
||||||
(error ()
|
(error ()
|
||||||
(harness-log "LISP REPAIR: Neural repair failed.")
|
(harness-log "LISP REPAIR: Neural repair failed.")
|
||||||
(list :type :LOG :payload (list :text "Lisp Repair Failed."))))))))))))
|
(list :type :LOG :payload (list :text "Lisp Repair Failed.")))))))))))
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Skill Definition: Lisp Validator
|
** Skill Definition: Lisp Validator
|
||||||
@@ -419,24 +419,37 @@ Validates all Lisp code before execution.
|
|||||||
|
|
||||||
(in-suite lisp-utils-suite)
|
(in-suite lisp-utils-suite)
|
||||||
|
|
||||||
|
;; Character utilities
|
||||||
|
;; Character utilities
|
||||||
(test count-char-balanced
|
(test count-char-balanced
|
||||||
(is (= (count-char #\( "(+ 1 2)") 1))
|
(is (= (opencortex::count-char #\( "(+ 1 2)") 1))
|
||||||
(is (= (count-char #\) "(+ 1 2)") 1))
|
(is (= (opencortex::count-char #\) "(+ 1 2)") 1)))
|
||||||
|
|
||||||
(test count-char-unbalanced
|
(test count-char-unbalanced
|
||||||
(is (= (count-char #\( "(+ 1 2") 1))
|
(is (= (opencortex::count-char #\( "(+ 1 2") 1))
|
||||||
(is (= (count-char #\) "(+ 1 2") 0))
|
(is (= (opencortex::count-char #\) "(+ 1 2") 0)))
|
||||||
|
|
||||||
|
(test count-char-empty
|
||||||
|
(is (= (opencortex::count-char #\( "") 0)))
|
||||||
|
|
||||||
|
;; Deterministic repair
|
||||||
(test deterministic-repair-balanced
|
(test deterministic-repair-balanced
|
||||||
(is (string= (deterministic-repair "(+ 1 2)") "(+ 1 2)")))
|
(is (string= (opencortex::deterministic-repair "(+ 1 2)") "(+ 1 2)")))
|
||||||
|
|
||||||
(test deterministic-repair-unbalanced
|
(test deterministic-repair-unbalanced-open
|
||||||
(is (string= (deterministic-repair "(+ 1 2") "(+ 1 2)")))
|
(is (string= (opencortex::deterministic-repair "(+ 1 2") "(+ 1 2)")))
|
||||||
|
|
||||||
|
(test deterministic-repair-unbalanced-close
|
||||||
|
(is (string= (opencortex::deterministic-repair "(+ 1 2))") "(+ 1 2))")))
|
||||||
|
|
||||||
|
(test deterministic-repair-empty
|
||||||
|
(is (string= (opencortex::deterministic-repair "") "")))
|
||||||
|
|
||||||
|
;; Structural check
|
||||||
(test structural-valid
|
(test structural-valid
|
||||||
(multiple-value-bind (ok reason line col)
|
(multiple-value-bind (ok reason line col)
|
||||||
(opencortex::lisp-utils-check-structural "(+ 1 2)")
|
(opencortex::lisp-utils-check-structural "(+ 1 2)")
|
||||||
(is ok)))
|
(is (eq ok t))))
|
||||||
|
|
||||||
(test structural-unbalanced
|
(test structural-unbalanced
|
||||||
(multiple-value-bind (ok reason line col)
|
(multiple-value-bind (ok reason line col)
|
||||||
@@ -444,21 +457,40 @@ Validates all Lisp code before execution.
|
|||||||
(is (not ok))
|
(is (not ok))
|
||||||
(is (search "Unbalanced" reason))))
|
(is (search "Unbalanced" reason))))
|
||||||
|
|
||||||
|
(test structural-mismatched
|
||||||
|
(multiple-value-bind (ok reason line col)
|
||||||
|
(opencortex::lisp-utils-check-structural "[)")
|
||||||
|
(is (not ok))
|
||||||
|
(is (search "Mismatched" reason))))
|
||||||
|
|
||||||
|
;; Syntactic check
|
||||||
(test syntactic-valid
|
(test syntactic-valid
|
||||||
(multiple-value-bind (ok reason line col)
|
(multiple-value-bind (ok reason line col)
|
||||||
(opencortex::lisp-utils-check-syntactic "(+ 1 2)")
|
(opencortex::lisp-utils-check-syntactic "(+ 1 2)")
|
||||||
(is ok)))
|
(is (eq ok t))))
|
||||||
|
|
||||||
(test semantic-whitelist
|
(test syntactic-invalid
|
||||||
|
(multiple-value-bind (ok reason line col)
|
||||||
|
(opencortex::lisp-utils-check-syntactic "(1+ 2 #\")")
|
||||||
|
(is (not ok))))
|
||||||
|
|
||||||
|
;; Semantic check
|
||||||
|
(test semantic-whitelist-safe
|
||||||
(multiple-value-bind (ok reason line col)
|
(multiple-value-bind (ok reason line col)
|
||||||
(opencortex::lisp-utils-check-semantic "(+ 1 2)")
|
(opencortex::lisp-utils-check-semantic "(+ 1 2)")
|
||||||
(is ok)))
|
(is (eq ok t))))
|
||||||
|
|
||||||
(test semantic-blocked
|
(test semantic-blocked-eval
|
||||||
|
(multiple-value-bind (ok reason line col)
|
||||||
|
(opencortex::lisp-utils-check-semantic "(eval '(+ 1 2))")
|
||||||
|
(is (not ok))))
|
||||||
|
|
||||||
|
(test semantic-blocked-delete
|
||||||
(multiple-value-bind (ok reason line col)
|
(multiple-value-bind (ok reason line col)
|
||||||
(opencortex::lisp-utils-check-semantic "(delete-file \"x.txt\")")
|
(opencortex::lisp-utils-check-semantic "(delete-file \"x.txt\")")
|
||||||
(is (not ok))))
|
(is (not ok))))
|
||||||
|
|
||||||
|
;; Unified validation
|
||||||
(test unified-success
|
(test unified-success
|
||||||
(let ((result (opencortex::lisp-utils-validate "(+ 1 2)" :strict t)))
|
(let ((result (opencortex::lisp-utils-validate "(+ 1 2)" :strict t)))
|
||||||
(is (eq (getf result :status) :success))))
|
(is (eq (getf result :status) :success))))
|
||||||
@@ -467,6 +499,16 @@ Validates all Lisp code before execution.
|
|||||||
(let ((result (opencortex::lisp-utils-validate "(+ 1 2" :strict nil)))
|
(let ((result (opencortex::lisp-utils-validate "(+ 1 2" :strict nil)))
|
||||||
(is (eq (getf result :status) :error))
|
(is (eq (getf result :status) :error))
|
||||||
(is (eq (getf result :failed) :structural))))
|
(is (eq (getf result :failed) :structural))))
|
||||||
|
|
||||||
|
(test unified-semantic-fail
|
||||||
|
(let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t)))
|
||||||
|
(is (eq (getf result :status) :error))
|
||||||
|
(is (eq (getf result :failed) :semantic))))
|
||||||
|
|
||||||
|
(test unified-semantic-fail
|
||||||
|
(let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t)))
|
||||||
|
(is (eq (getf result :status) :error))
|
||||||
|
(is (eq (getf result :failed) :semantic))))
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
* See Also
|
* See Also
|
||||||
|
|||||||
@@ -114,6 +114,24 @@ The gateway utilizes a functional dispatch pattern. A single entry point, `execu
|
|||||||
(opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model)
|
(opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model)
|
||||||
(execute-llm-request prompt system-prompt :provider p :model model))))
|
(execute-llm-request prompt system-prompt :provider p :model model))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :get-ollama-embedding
|
||||||
|
"Generates vector embeddings via Ollama API for semantic search."
|
||||||
|
((text :type :string :description "Text to embed."))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let* ((text (getf args :text))
|
||||||
|
(host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||||
|
(url (format nil "http://~a/api/embeddings" host))
|
||||||
|
(model (or (uiop:getenv "OLLAMA_EMBEDDING_MODEL") "nomic-embed-text"))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response)))
|
||||||
|
(let ((embedding (cdr (assoc :embedding json))))
|
||||||
|
(if embedding
|
||||||
|
(list :status :success :vector embedding)
|
||||||
|
(list :status :error :message "No embedding in response"))))
|
||||||
|
(error (c) (list :status :error :message (format nil "Ollama Embedding Failure: ~a" c)))))))
|
||||||
|
|
||||||
(def-cognitive-tool :ask-llm
|
(def-cognitive-tool :ask-llm
|
||||||
"Queries an LLM provider via the unified gateway."
|
"Queries an LLM provider via the unified gateway."
|
||||||
((:prompt :type :string :description "The user prompt.")
|
((:prompt :type :string :description "The user prompt.")
|
||||||
|
|||||||
118
skills/org-skill-tool-permissions.org
Normal file
118
skills/org-skill-tool-permissions.org
Normal file
@@ -0,0 +1,118 @@
|
|||||||
|
:PROPERTIES:
|
||||||
|
:ID: tool-permissions-skill-001
|
||||||
|
:CREATED: [2026-04-23 Thu]
|
||||||
|
:END:
|
||||||
|
#+TITLE: SKILL: Tool Permission Tiers
|
||||||
|
#+STARTUP: content
|
||||||
|
#+FILETAGS: :security:permissions:tool:
|
||||||
|
|
||||||
|
* Overview
|
||||||
|
This skill implements tool permission tiers for security - controlling which cognitive tools can execute without user interaction.
|
||||||
|
|
||||||
|
Also provides vector embeddings via Ollama or llama.cpp.
|
||||||
|
|
||||||
|
** The Three Tiers
|
||||||
|
|
||||||
|
| Tier | Behavior | Use Case |
|
||||||
|
|------|----------|----------|
|
||||||
|
| =:allow= | Executes immediately | Trusted, safe tools |
|
||||||
|
| =:deny= | Blocks before execution | Dangerous tools |
|
||||||
|
| =:ask= | Prompts user, pauses execution | Sensitive tools |
|
||||||
|
|
||||||
|
** Embedding Providers
|
||||||
|
- =EMBEDDING_PROVIDER= environment: "ollama" or "llama.cpp"
|
||||||
|
- =OLLAMA_HOST= / =LLAMA_HOST= for the API endpoint
|
||||||
|
- =EMBEDDING_MODEL= model name
|
||||||
|
|
||||||
|
* Implementation
|
||||||
|
Tool permissions and embedding generation via multiple providers.
|
||||||
|
|
||||||
|
#+begin_src lisp :tangle ../library/gen/org-skill-tool-permissions.lisp
|
||||||
|
(in-package :opencortex)
|
||||||
|
|
||||||
|
(defvar *tool-permissions* (make-hash-table :test 'equal)
|
||||||
|
"Hash table mapping tool names to :allow/:deny/:ask.")
|
||||||
|
|
||||||
|
(defun get-tool-permission (tool-name)
|
||||||
|
(let ((key (string-downcase (string tool-name))))
|
||||||
|
(or (gethash key *tool-permissions*) :allow)))
|
||||||
|
|
||||||
|
(defun set-tool-permission (tool-name tier)
|
||||||
|
(setf (gethash (string-downcase (string tool-name)) *tool-permissions*) tier)
|
||||||
|
(harness-log "TOOL PERMISSION: Set ~a = ~a" tool-name tier))
|
||||||
|
|
||||||
|
(defun check-tool-permission-gate (tool-name context)
|
||||||
|
(declare (ignore context))
|
||||||
|
(let ((perm (get-tool-permission tool-name)))
|
||||||
|
(case perm
|
||||||
|
(:allow :allow)
|
||||||
|
(:deny :deny)
|
||||||
|
(:ask (list :ask tool-name context))
|
||||||
|
(t :allow))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :get-embedding
|
||||||
|
"Generates vector embeddings via Ollama or llama.cpp API."
|
||||||
|
((:text :type :string :description "Text to embed."))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let* ((text (getf args :text))
|
||||||
|
(provider (or (uiop:getenv "EMBEDDING_PROVIDER") "ollama"))
|
||||||
|
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||||
|
(embedding nil))
|
||||||
|
(cond
|
||||||
|
((string= provider "ollama")
|
||||||
|
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||||
|
(url (format nil "http://~a/api/embeddings" host))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response))
|
||||||
|
(vec (cdr (assoc :embedding json))))
|
||||||
|
(when vec (setf embedding vec)))
|
||||||
|
(error (c) (harness-log "EMBEDDING: Ollama failed: ~a" c)))))
|
||||||
|
((string= provider "llama.cpp")
|
||||||
|
(let* ((host (or (uiop:getenv "LLAMA_HOST") "localhost:8080"))
|
||||||
|
(url (format nil "http://~a/v1/embeddings" host))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,model) (input . ,text)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response))
|
||||||
|
(data (cdr (assoc :data json)))
|
||||||
|
(vec (when data (cdr (assoc :embedding (car data))))))
|
||||||
|
(when vec (setf embedding vec)))
|
||||||
|
(error (c) (harness-log "EMBEDDING: llama.cpp failed: ~a" c))))))
|
||||||
|
(if embedding
|
||||||
|
(list :status :success :vector embedding)
|
||||||
|
(list :status :error :message "Embedding generation failed")))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :tool-permissions
|
||||||
|
"View or set tool permission tiers."
|
||||||
|
((:tool :type :string :description "Tool name")
|
||||||
|
(:action :type :keyword :description "Action: :get, :set, :list" :default :get)
|
||||||
|
(:tier :type :keyword :description "For :set: :allow/:deny/:ask"))
|
||||||
|
:body (lambda (args)
|
||||||
|
(let ((tool (getf args :tool))
|
||||||
|
(action (getf args :action :get))
|
||||||
|
(tier (getf args :tier)))
|
||||||
|
(case action
|
||||||
|
(:get (list :status :success :tool tool :permission (get-tool-permission tool)))
|
||||||
|
(:set (progn (set-tool-permission tool tier)
|
||||||
|
(list :status :success :message (format nil "Set ~a = ~a" tool tier))))
|
||||||
|
(:list (let ((r nil))
|
||||||
|
(maphash (lambda (k v) (push (list :tool k :permission v) r)) *tool-permissions*)
|
||||||
|
(list :status :success :tools r)))
|
||||||
|
(t (list :status :error :message "Invalid action"))))))
|
||||||
|
|
||||||
|
;; Defaults
|
||||||
|
(set-tool-permission :shell :deny)
|
||||||
|
(set-tool-permission :delete-file :deny)
|
||||||
|
(set-tool-permission :eval :ask)
|
||||||
|
(set-tool-permission :write-file :ask)
|
||||||
|
(harness-log "TOOL PERMISSIONS: Initialized")
|
||||||
|
|
||||||
|
(defskill :skill-tool-permissions
|
||||||
|
:priority 600
|
||||||
|
:trigger (lambda (c) (declare (ignore c)) nil)
|
||||||
|
:deterministic (lambda (a c)
|
||||||
|
(let ((tool (getf (getf a :payload) :tool)))
|
||||||
|
(when tool (check-tool-permission-gate tool c)))))
|
||||||
|
#+end_src
|
||||||
Reference in New Issue
Block a user