Amr Gharbeia
8fd56dece3
Phase 1 — dedup + hardening (~9 items): - Remove duplicate *skill-registry* defvar from core-skills - Merge *backend-registry* into *probabilistic-backends*, delete backend-register - Remove inject-stimulus alias, standardize on stimulus-inject - Add pre-eval sandbox (skill-source-scan) blocks restricted symbols before eval - Remove dead plist-get function; remove duplicate json-alist-to-plist export - Fix read-framed-message whitespace DoS (4096-iteration max) - Add *read-eval* nil to dispatcher-approvals-process read-from-string (RCE) - Add test-op to ASDF; update .asd version 0.4.3→0.7.2 Phase 2 — prose + contracts + reorder: - Split ROADMAP: 2623→1089 lines (TODO only), CHANGELOG: 260→1528 lines (full DONE history, 14 versions reverse chron) - Add Contracts + Overview to 6 channel files + embedding-native + programming-standards + symbolic-scope - Reorder 28 .org files: Contract → Test Suite → Implementation (TDD order) - Add 7-phase inline prose to think() in core-reason - Expand USER_MANUAL: 183→461 lines (10 new sections) Phase 3 — decomposition + export organization: - Decompose think() into think-assemble-prompt, think-call-llm, think-parse-response orchestrator - Organize 188 exports into 16 grouped sections by module Phase 4 — budget enforcement + error protocol: - Per-session budget enforcement (SESSION_BUDGET_USD env var, budget-exhausted-p, guard in think-call-llm) - Error condition hierarchy (6 conditions: pipeline-error, llm-error, gate-error, budget-error, protocol-error) - Restarts in loop-process: skip-signal, use-fallback, abort-pipeline
352 lines
16 KiB
Common Lisp
352 lines
16 KiB
Common Lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-memory-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:memory-suite))
|
|
|
|
(in-package :passepartout-memory-tests)
|
|
|
|
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
|
(in-suite memory-suite)
|
|
|
|
(test merkle-hash-consistency
|
|
"Contract 2: identical ASTs produce identical Merkle hashes."
|
|
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
|
(clrhash passepartout::*memory-store*)
|
|
(let ((id1 (ingest-ast ast1)))
|
|
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
|
(clrhash passepartout::*memory-store*)
|
|
(let ((id2 (ingest-ast ast1)))
|
|
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
|
|
|
(test merkle-hash-different
|
|
"Contract 2: distinct ASTs produce different Merkle hashes."
|
|
(clrhash passepartout::*memory-store*)
|
|
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
|
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
|
(id1 (ingest-ast ast1))
|
|
(id2 (ingest-ast ast2))
|
|
(hash1 (memory-object-hash (memory-object-get id1)))
|
|
(hash2 (memory-object-hash (memory-object-get id2))))
|
|
(is (not (equal hash1 hash2)))))
|
|
|
|
(test test-ingest-ast-returns-id
|
|
"Contract 1: ingest-ast returns a string ID and stores the object."
|
|
(clrhash passepartout::*memory-store*)
|
|
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
|
(is (stringp id))
|
|
(is (not (null id)))))
|
|
|
|
(test test-memory-object-get
|
|
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
|
(clrhash passepartout::*memory-store*)
|
|
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
|
(let ((obj (memory-object-get id)))
|
|
(is (not (null obj)))
|
|
(is (eq :HEADLINE (memory-object-type obj)))
|
|
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
|
|
|
(test test-snapshot-and-rollback
|
|
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
|
(clrhash passepartout::*memory-store*)
|
|
(setf passepartout::*memory-snapshots* nil)
|
|
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
|
(snapshot-memory)
|
|
(clrhash passepartout::*memory-store*)
|
|
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
|
(rollback-memory 0)
|
|
(is (not (null (memory-object-get "snap-a"))))
|
|
(is (null (memory-object-get "snap-b"))))
|
|
|
|
(test test-undo-snapshot-restore
|
|
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
|
(let ((orig-store passepartout::*memory-store*)
|
|
(orig-undo passepartout::*undo-stack*)
|
|
(orig-redo passepartout::*redo-stack*))
|
|
(unwind-protect
|
|
(progn
|
|
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
|
passepartout::*undo-stack* nil
|
|
passepartout::*redo-stack* nil)
|
|
(passepartout::undo-snapshot)
|
|
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
|
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
|
(is (passepartout::undo))
|
|
(is (null (gethash "x" passepartout::*memory-store*))))
|
|
(setf passepartout::*memory-store* orig-store
|
|
passepartout::*undo-stack* orig-undo
|
|
passepartout::*redo-stack* orig-redo))))
|
|
|
|
(test test-undo-redo-cycle
|
|
"Contract v0.7.2: redo restores undone state."
|
|
(let ((orig-store passepartout::*memory-store*)
|
|
(orig-undo passepartout::*undo-stack*)
|
|
(orig-redo passepartout::*redo-stack*))
|
|
(unwind-protect
|
|
(progn
|
|
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
|
passepartout::*undo-stack* nil
|
|
passepartout::*redo-stack* nil)
|
|
(passepartout::undo-snapshot)
|
|
(setf (gethash "y" passepartout::*memory-store*) "world")
|
|
(is (passepartout::undo))
|
|
(is (null (gethash "y" passepartout::*memory-store*)))
|
|
(is (passepartout::redo))
|
|
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
|
(setf passepartout::*memory-store* orig-store
|
|
passepartout::*undo-stack* orig-undo
|
|
passepartout::*redo-stack* orig-redo))))
|
|
|
|
(test test-undo-empty-stack-nil
|
|
"Contract v0.7.2: undo returns nil on empty stack."
|
|
(let ((orig-undo passepartout::*undo-stack*))
|
|
(unwind-protect
|
|
(progn (setf passepartout::*undo-stack* nil)
|
|
(is (null (passepartout::undo))))
|
|
(setf passepartout::*undo-stack* orig-undo))))
|
|
|
|
(test test-audit-node-found
|
|
"Contract v0.7.2: audit-node returns info for existing object."
|
|
(clrhash passepartout::*memory-store*)
|
|
(setf (gethash "audit-1" passepartout::*memory-store*)
|
|
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
|
:version 1 :hash "abc123" :scope :memex))
|
|
(let ((info (passepartout::audit-node "audit-1")))
|
|
(is (not (null info)))
|
|
(is (eq :HEADLINE (getf info :type)))
|
|
(is (string= "abc123" (getf info :hash)))))
|
|
|
|
(test test-audit-node-not-found
|
|
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
|
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
|
|
|
(test test-audit-verify-hash
|
|
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
|
(clrhash passepartout::*memory-store*)
|
|
(setf (gethash "a" passepartout::*memory-store*)
|
|
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
|
(let ((result (passepartout::audit-verify-hash)))
|
|
(is (= 1 (car result)))
|
|
(is (= 0 (cdr result)))))
|
|
|
|
(in-package :passepartout)
|
|
|
|
(defvar *memory-store* (make-hash-table :test 'equal))
|
|
|
|
(defvar *memory-history* (make-hash-table :test 'equal)
|
|
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
|
|
|
(defun memory-object-get (id)
|
|
"Retrieves an memory-object by ID from *memory-store*."
|
|
(gethash id *memory-store*))
|
|
|
|
(defun memory-objects-by-attribute (attr value)
|
|
"Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE."
|
|
(let ((results nil))
|
|
(maphash (lambda (id obj)
|
|
(declare (ignore id))
|
|
(when (equal (getf (memory-object-attributes obj) attr) value)
|
|
(push obj results)))
|
|
*memory-store*)
|
|
(nreverse results)))
|
|
|
|
(defun memory-id-generate ()
|
|
"Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs."
|
|
(concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid)))))
|
|
|
|
(defstruct memory-object
|
|
id type attributes content vector parent-id children version last-sync hash scope)
|
|
|
|
(defmethod make-load-form ((obj memory-object) &optional env)
|
|
(make-load-form-saving-slots obj :environment env))
|
|
|
|
(defun deep-copy-memory-object (obj)
|
|
"Creates a full copy of an memory-object, including fresh lists for attributes and children."
|
|
(make-memory-object :id (memory-object-id obj)
|
|
:type (memory-object-type obj)
|
|
:attributes (copy-list (memory-object-attributes obj))
|
|
:content (memory-object-content obj)
|
|
:vector (memory-object-vector obj)
|
|
:parent-id (memory-object-parent-id obj)
|
|
:children (copy-list (memory-object-children obj))
|
|
:version (memory-object-version obj)
|
|
:last-sync (memory-object-last-sync obj)
|
|
:hash (memory-object-hash obj)
|
|
:scope (memory-object-scope obj)))
|
|
|
|
(defun memory-merkle-hash (id type attributes content child-hashes)
|
|
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
|
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
|
(attr-string (format nil "~s" sorted-alist))
|
|
(children-string (format nil "~{~a~}" child-hashes))
|
|
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
|
id type attr-string (or content "") children-string))
|
|
(digester (ironclad:make-digest :sha256)))
|
|
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
|
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
|
|
|
(defun ingest-ast (ast &key parent-id (scope :memex))
|
|
(let* ((type (getf ast :type))
|
|
(props (getf ast :properties))
|
|
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
|
(contents (getf ast :contents))
|
|
(raw-content (when (eq type :HEADLINE)
|
|
(format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) ""))))
|
|
(child-ids nil) (child-hashes nil))
|
|
(dolist (child contents)
|
|
(when (listp child)
|
|
(let ((child-id (ingest-ast child :parent-id id :scope scope)))
|
|
(push child-id child-ids)
|
|
(let ((child-obj (gethash child-id *memory-store*)))
|
|
(when child-obj (push (memory-object-hash child-obj) child-hashes))))))
|
|
(setf child-ids (nreverse child-ids))
|
|
(setf child-hashes (nreverse child-hashes))
|
|
(let* ((hash (memory-merkle-hash id type props raw-content child-hashes))
|
|
(existing-obj (gethash hash *memory-history*))
|
|
(obj (or existing-obj
|
|
(make-memory-object
|
|
:id id :type type :attributes props :content raw-content
|
|
:parent-id parent-id :children child-ids
|
|
:version (get-universal-time) :last-sync (get-universal-time)
|
|
:hash hash :scope scope))))
|
|
(unless existing-obj (setf (gethash hash *memory-history*) obj))
|
|
(setf (gethash id *memory-store*) obj)
|
|
;; Populate embedding vector for new objects
|
|
(when (and raw-content (not existing-obj) (not (memory-object-vector obj)))
|
|
(handler-case
|
|
(setf (memory-object-vector obj)
|
|
(embeddings-compute raw-content))
|
|
(error (c)
|
|
(log-message "INGEST: Embedding deferred: ~a" c))))
|
|
id)))
|
|
|
|
(defvar *memory-snapshots* nil)
|
|
|
|
(defun memory-hash-table-copy (hash-table)
|
|
"Creates an independent copy of a hash table."
|
|
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
|
:size (hash-table-size hash-table))))
|
|
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
|
new-table))
|
|
|
|
(defun snapshot-memory ()
|
|
"Creates a CoW snapshot of *memory-store* for rollback recovery."
|
|
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory-store*))))
|
|
(maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-memory-object v))) *memory-store*)
|
|
(push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*)
|
|
(when (> (length *memory-snapshots*) 20)
|
|
(setf *memory-snapshots* (subseq *memory-snapshots* 0 20)))
|
|
(log-message "MEMORY - CoW Memory snapshot created.")))
|
|
|
|
(defun rollback-memory (&optional (index 0))
|
|
"Restores *memory-store* from a snapshot. INDEX 0 = most recent."
|
|
(let ((snapshot (nth index *memory-snapshots*)))
|
|
(if snapshot
|
|
(progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data)))
|
|
(log-message "MEMORY - Memory rolled back to snapshot ~a" index))
|
|
(log-message "MEMORY ERROR - Snapshot ~a not found." index))))
|
|
|
|
(defvar *memory-snapshot-path* nil)
|
|
|
|
(defun memory-snapshot-path-ensure ()
|
|
"Returns the path to the memory snapshot file, resolving env or default."
|
|
(or *memory-snapshot-path*
|
|
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
|
(setf *memory-snapshot-path*
|
|
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
|
|
|
(defun save-memory-to-disk ()
|
|
"Writes the entire memory and history store to disk as a plist."
|
|
(let ((path (memory-snapshot-path-ensure)))
|
|
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(let ((memory-alist nil) (history-alist nil))
|
|
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory-store*)
|
|
(maphash (lambda (k v) (push (cons k v) history-alist)) *memory-history*)
|
|
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
|
(log-message "MEMORY - Saved to ~a" path)))
|
|
|
|
(defun load-memory-from-disk ()
|
|
"Reads memory state from disk and restores *memory-store* and *memory-history*."
|
|
(let ((path (memory-snapshot-path-ensure)))
|
|
(when (uiop:file-exists-p path)
|
|
(handler-case
|
|
(with-open-file (stream path :direction :input)
|
|
(let ((data (let ((*read-eval* nil)) (read stream nil))))
|
|
(when data
|
|
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
|
|
(setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist)))
|
|
(dolist (kv memory-alist) (setf (gethash (car kv) *memory-store*) (cdr kv)))
|
|
(setf *memory-history* (make-hash-table :test 'equal :size (length history-alist)))
|
|
(dolist (kv history-alist) (setf (gethash (car kv) *memory-history*) (cdr kv)))
|
|
(log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*))))))
|
|
(error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
|
|
t)
|
|
|
|
;; v0.7.2 — Undo/Redo
|
|
(defvar *undo-stack* nil
|
|
"Ring buffer of pre-operation memory snapshots. Newest first, max 20.")
|
|
(defvar *redo-stack* nil
|
|
"Stack of snapshots saved during undo for redo. Max 20.")
|
|
|
|
(defun undo-snapshot ()
|
|
"Save current memory state to the undo stack."
|
|
(let ((snap (list :timestamp (get-universal-time)
|
|
:data (memory-hash-table-copy *memory-store*))))
|
|
(push snap *undo-stack*)
|
|
(when (> (length *undo-stack*) 20)
|
|
(setf *undo-stack* (subseq *undo-stack* 0 20)))))
|
|
|
|
(defun undo (&optional source)
|
|
"Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty."
|
|
(declare (ignore source))
|
|
(if *undo-stack*
|
|
(let ((snap (pop *undo-stack*)))
|
|
(push (list :timestamp (get-universal-time)
|
|
:data (memory-hash-table-copy *memory-store*))
|
|
*redo-stack*)
|
|
(when (> (length *redo-stack*) 20)
|
|
(setf *redo-stack* (subseq *redo-stack* 0 20)))
|
|
(setf *memory-store* (memory-hash-table-copy (getf snap :data)))
|
|
(log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp))
|
|
t)
|
|
(progn (log-message "UNDO: No snapshots to undo") nil)))
|
|
|
|
(defun redo (&optional source)
|
|
"Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty."
|
|
(declare (ignore source))
|
|
(if *redo-stack*
|
|
(let ((snap (pop *redo-stack*)))
|
|
(push (list :timestamp (get-universal-time)
|
|
:data (memory-hash-table-copy *memory-store*))
|
|
*undo-stack*)
|
|
(when (> (length *undo-stack*) 20)
|
|
(setf *undo-stack* (subseq *undo-stack* 0 20)))
|
|
(setf *memory-store* (memory-hash-table-copy (getf snap :data)))
|
|
(log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp))
|
|
t)
|
|
(progn (log-message "REDO: No snapshots to redo") nil)))
|
|
|
|
(defun audit-node (node-id)
|
|
"Return audit info for a memory object by ID."
|
|
(let ((obj (memory-object-get node-id)))
|
|
(when obj
|
|
(list :id node-id :type (memory-object-type obj)
|
|
:version (memory-object-version obj)
|
|
:hash (or (memory-object-hash obj) "(none)")
|
|
:scope (memory-object-scope obj)))))
|
|
|
|
(defun audit-verify-hash ()
|
|
"Count memory objects and report any with missing/empty hashes.
|
|
Returns (total . missing-hashes)."
|
|
(let ((total 0) (missing 0))
|
|
(maphash (lambda (id obj)
|
|
(declare (ignore id))
|
|
(when obj
|
|
(incf total)
|
|
(let ((h (memory-object-hash obj)))
|
|
(when (or (null h) (string= h ""))
|
|
(incf missing)))))
|
|
*memory-store*)
|
|
(cons total missing)))
|