Amr Gharbeia
620267a8df
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 2s
- Add save-memory-to-disk and load-memory-from-disk to memory.lisp
- Integrate auto-save into heartbeat (every N intervals)
- Load memory on daemon startup, save on graceful shutdown/SIGINT
- Add exports to package.lisp
NOTE: Hash table serialization requires object walker for complex structures.
Current implementation fails on load due to unreadable objects.
152 lines
6.9 KiB
Common Lisp
152 lines
6.9 KiB
Common Lisp
(in-package :opencortex)
|
|
|
|
(defvar *memory* (make-hash-table :test 'equal))
|
|
|
|
(defvar *history-store* (make-hash-table :test 'equal)
|
|
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
|
|
|
(defstruct org-object
|
|
id type attributes content vector parent-id children version last-sync hash)
|
|
|
|
(defun compute-merkle-hash (id type attributes content child-hashes)
|
|
"Computes a SHA-256 Merkle hash for a node based on its core properties and children's hashes."
|
|
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
|
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
|
(attr-string (format nil "~s" sorted-alist))
|
|
(children-string (format nil "~{~a~}" child-hashes))
|
|
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
|
id type attr-string (or content "") children-string))
|
|
(digester (ironclad:make-digest :sha256)))
|
|
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
|
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
|
|
|
(defun ingest-ast (ast &optional parent-id)
|
|
"Parses an Org AST into the recursive Lisp Memory with Merkle hashing."
|
|
(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 (cl:getf ast :raw-content) ""))))
|
|
(should-embed (and raw-content (equal (getf props :EMBED) "t")))
|
|
(child-ids nil)
|
|
(child-hashes nil))
|
|
(dolist (child contents)
|
|
(when (listp child)
|
|
(let ((child-id (ingest-ast child id)))
|
|
(push child-id child-ids)
|
|
(let ((child-id-val child-id))
|
|
(let ((child-obj (lookup-object child-id-val)))
|
|
(when child-obj (push (org-object-hash child-obj) child-hashes)))))))
|
|
(setf child-ids (nreverse child-ids))
|
|
(setf child-hashes (nreverse child-hashes))
|
|
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
|
(existing-obj (gethash hash *history-store*))
|
|
(obj (or existing-obj
|
|
(make-org-object
|
|
:id id :type type :attributes props :content raw-content
|
|
:vector (when should-embed (get-embedding raw-content))
|
|
:parent-id parent-id :children child-ids
|
|
:version (get-universal-time) :last-sync (get-universal-time)
|
|
:hash hash))))
|
|
(unless existing-obj
|
|
(setf (gethash hash *history-store*) obj))
|
|
(setf (gethash id *memory*) obj)
|
|
id)))
|
|
|
|
(defvar *object-store-snapshots* nil)
|
|
|
|
(defun copy-hash-table (hash-table)
|
|
"Creates a shallow 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 lightweight, Copy-on-Write snapshot using Merkle-Tree pointers."
|
|
(let ((snapshot (copy-hash-table *memory*)))
|
|
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
|
(when (> (length *object-store-snapshots*) 20)
|
|
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
|
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
|
|
|
(defun rollback-memory (&optional (index 0))
|
|
"Restores the Memory to a previously captured snapshot using immutable history pointers."
|
|
(let ((snapshot (nth index *object-store-snapshots*)))
|
|
(if snapshot
|
|
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
|
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
|
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
|
|
|
(defvar *memory-snapshot-path* nil
|
|
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
|
|
|
|
(defun ensure-memory-snapshot-path ()
|
|
"Initializes the snapshot path from environment or default location."
|
|
(or *memory-snapshot-path*
|
|
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
|
(setf *memory-snapshot-path*
|
|
(or env-path
|
|
(uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))
|
|
|
|
(defun save-memory-to-disk ()
|
|
"Serializes *memory* and *history-store* to disk for crash recovery."
|
|
(let ((path (ensure-memory-snapshot-path)))
|
|
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(format stream ";; OpenCortex Memory Snapshot~%")
|
|
(format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time)))
|
|
(prin1 (list :memory *memory* :history-store *history-store*) stream))
|
|
(harness-log "MEMORY - Saved to ~a" path)
|
|
path))
|
|
|
|
(defun load-memory-from-disk ()
|
|
"Loads *memory* and *history-store* from disk if the snapshot exists."
|
|
(let ((path (ensure-memory-snapshot-path)))
|
|
(when (uiop:file-exists-p path)
|
|
(handler-case
|
|
(with-open-file (stream path :direction :input)
|
|
(let ((data (read stream nil)))
|
|
(when data
|
|
(setf *memory* (getf data :memory))
|
|
(setf *history-store* (getf data :history-store))
|
|
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*)))))
|
|
(error (c)
|
|
(harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))
|
|
t))
|
|
|
|
(defun org-id-new ()
|
|
"Generates a new UUID string for Org-mode identification."
|
|
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
|
|
|
(defun lookup-object (id)
|
|
"Retrieves an object from the store by its unique ID."
|
|
(gethash id *memory*))
|
|
|
|
(defun list-objects-by-type (type)
|
|
"Returns a list of all objects matching a specific Org element type."
|
|
(let ((results nil))
|
|
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *memory*)
|
|
results))
|
|
(defun list-objects-with-attribute (attr-name value)
|
|
"Returns a list of all objects where ATTR-NAME matches VALUE."
|
|
(let ((results nil))
|
|
(maphash (lambda (id obj)
|
|
(declare (ignore id))
|
|
(let ((attrs (org-object-attributes obj)))
|
|
(when (equal (getf attrs attr-name) value)
|
|
(push obj results))))
|
|
*memory*)
|
|
results))
|
|
|
|
(defun find-headline-missing-id (ast)
|
|
"Traverses an AST to find headlines that lack an :ID: property."
|
|
(when (listp ast)
|
|
(if (and (eq (getf ast :type) :HEADLINE) (not (getf (getf ast :properties) :ID)))
|
|
ast
|
|
(cl:some #'find-headline-missing-id (getf ast :contents)))))
|
|
|
|
(defun file-name-nondirectory (path)
|
|
"Extracts the filename from a full path string."
|
|
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|