Amr Gharbeia
924bf8f479
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- Restore (in-package :passepartout) to core-reason - Move *VAULT-MEMORY* back to core-skills - Fix ASDF and defstruct/defpackage ordering - Increase daemon timeout to 120s - Handshake: 0.5.0 Verified: daemon processes messages, TUI clean, gate trace works
280 lines
12 KiB
Common Lisp
280 lines
12 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(in-package :passepartout)
|
|
|
|
(defvar *archivist-last-scribe* 0
|
|
"Universal time of the last Scribe distillation run.")
|
|
|
|
(defvar *archivist-last-gardener* 0
|
|
"Universal time of the last Gardener scan run.")
|
|
|
|
(defvar *archivist-gardener-interval* 86400
|
|
"Seconds between Gardener scans. Default: 24 hours.")
|
|
|
|
(defun archivist-scribe-distill ()
|
|
"Distills daily log entries into atomic notes. Reads the Memex daily/
|
|
directory for log files modified since the last run, extracts headlines
|
|
as potential note seeds, and creates atomic note files in notes/ with
|
|
backlinks to the source daily entry."
|
|
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
|
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
|
(daily-dir (merge-pathnames "daily/" memex-dir))
|
|
(notes-dir (merge-pathnames "notes/" memex-dir))
|
|
(now (get-universal-time))
|
|
(notes-created 0))
|
|
(unless (uiop:directory-exists-p daily-dir)
|
|
(log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir)
|
|
(return-from archivist-scribe-distill nil))
|
|
(ensure-directories-exist notes-dir)
|
|
(handler-case
|
|
(let ((daily-files (uiop:directory-files daily-dir "*.org")))
|
|
(dolist (file daily-files)
|
|
(let* ((filepath (namestring file))
|
|
(file-mtime (ignore-errors (file-write-date filepath))))
|
|
(when (and file-mtime (> file-mtime *archivist-last-scribe*))
|
|
;; Extract headlines from daily log
|
|
(let* ((content (handler-case (uiop:read-file-string filepath)
|
|
(error () nil)))
|
|
(headlines (when content
|
|
(archivist-extract-headlines content))))
|
|
(dolist (hl headlines)
|
|
(when (archivist-create-note hl notes-dir filepath)
|
|
(incf notes-created))))))))
|
|
(error (c)
|
|
(log-message "ARCHIVIST: Scribe error: ~a" c)))
|
|
(setf *archivist-last-scribe* now)
|
|
(when (> notes-created 0)
|
|
(log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created))
|
|
notes-created))
|
|
|
|
(defun archivist-extract-headlines (content)
|
|
"Extracts first-level headlines and their content from Org text.
|
|
Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
|
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(results nil)
|
|
(current-title nil)
|
|
(current-lines nil)
|
|
(current-tags nil)
|
|
(in-properties nil))
|
|
(dolist (line lines)
|
|
(let ((trimmed (string-trim '(#\Space) line)))
|
|
(when (string= trimmed ":PROPERTIES:")
|
|
(setf in-properties t))
|
|
(when (string= trimmed ":END:")
|
|
(setf in-properties nil))
|
|
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
|
(setf current-tags
|
|
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
|
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
|
:separator '(#\space #\tab)))))
|
|
(cond
|
|
;; First-level headline
|
|
((and (uiop:string-prefix-p "* " trimmed)
|
|
(not (uiop:string-prefix-p "**" trimmed)))
|
|
;; Save previous
|
|
(when current-title
|
|
(push (list :title current-title
|
|
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
|
:tags current-tags)
|
|
results))
|
|
(setf current-title (string-trim '(#\* #\Space) trimmed)
|
|
current-lines nil
|
|
current-tags nil
|
|
in-properties nil))
|
|
;; Content lines under current headline
|
|
(current-title
|
|
(unless (or (uiop:string-prefix-p "*" trimmed)
|
|
(string= trimmed ":PROPERTIES:")
|
|
(string= trimmed ":END:"))
|
|
(push line current-lines))))))
|
|
;; Save last headline
|
|
(when current-title
|
|
(push (list :title current-title
|
|
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
|
:tags current-tags)
|
|
results))
|
|
(nreverse results)))
|
|
|
|
(defun archivist-headline-to-filename (title)
|
|
"Converts a headline title to a valid atomic note filename.
|
|
Replaces spaces and special chars with underscores, downcases."
|
|
(let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title ""))
|
|
(underscored (cl-ppcre:regex-replace-all "\\s+" clean "_"))
|
|
(lowered (string-downcase underscored)))
|
|
(if (> (length lowered) 100)
|
|
(subseq lowered 0 100)
|
|
lowered)))
|
|
|
|
(defun archivist-create-note (headline notes-dir source-filepath)
|
|
"Creates an atomic note from a headline plist in the notes/ directory.
|
|
Headline is a plist (:title <str> :content <str> :tags <list>).
|
|
Returns T if note was created, nil if it already exists."
|
|
(let* ((title (getf headline :title))
|
|
(content (or (getf headline :content) ""))
|
|
(tags (getf headline :tags))
|
|
(filename (archivist-headline-to-filename title))
|
|
(filepath (merge-pathnames (format nil "~a.org" filename) notes-dir))
|
|
(source-basename (enough-namestring source-filepath
|
|
(merge-pathnames "" notes-dir))))
|
|
(when (uiop:file-exists-p filepath)
|
|
(return-from archivist-create-note nil))
|
|
(handler-case
|
|
(progn
|
|
(uiop:with-output-file (s filepath :if-exists nil)
|
|
(format s "#+TITLE: ~a~%" title)
|
|
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
|
(format s "~%* ~a~%" title)
|
|
(format s ":PROPERTIES:~%")
|
|
(format s ":CREATED: ~a~%" (org-id-generate))
|
|
(format s ":SOURCE: ~a~%" source-basename)
|
|
(format s ":END:~%")
|
|
(format s "~%~a~%" content)
|
|
(format s "~%* Backlinks~%")
|
|
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
|
(file-namestring source-filepath)))
|
|
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
|
t)
|
|
(error (c)
|
|
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
|
nil))))
|
|
|
|
(defun archivist-gardener-scan ()
|
|
"Scans the Memex for broken file links and orphaned memory objects.
|
|
Broken links are =[[file:...]]= references whose target file does not exist.
|
|
Orphaned objects are =memory-object= entries whose =:parent-id= references
|
|
a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
|
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
|
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
|
(org-files (archivist-find-org-files memex-dir))
|
|
(broken-links 0)
|
|
(orphans 0))
|
|
;; Scan for broken links
|
|
(dolist (file org-files)
|
|
(handler-case
|
|
(let* ((content (uiop:read-file-string file))
|
|
(links (archivist-extract-file-links content)))
|
|
(dolist (link links)
|
|
(let ((target (merge-pathnames link (make-pathname :directory
|
|
(pathname-directory file)))))
|
|
(unless (uiop:file-exists-p target)
|
|
(log-message "ARCHIVIST: Broken link in ~a -> ~a"
|
|
(enough-namestring file memex-dir) link)
|
|
(incf broken-links)))))
|
|
(error ()
|
|
(log-message "ARCHIVIST: Could not read ~a" file))))
|
|
;; Scan for orphaned memory objects
|
|
(handler-case
|
|
(let ((deleted-ids (make-hash-table :test 'equal)))
|
|
;; In practice, we check if parent-id points to a non-existent object
|
|
(maphash (lambda (id obj)
|
|
(declare (ignore obj))
|
|
(setf (gethash id deleted-ids) t))
|
|
(if (boundp '*memory-store*)
|
|
(symbol-value '*memory-store*)
|
|
(make-hash-table :test 'equal)))
|
|
(let ((store (if (boundp '*memory-store*)
|
|
(symbol-value '*memory-store*)
|
|
(make-hash-table :test 'equal))))
|
|
(maphash (lambda (id obj)
|
|
(let ((parent (memory-object-parent-id obj)))
|
|
(when (and parent (not (gethash parent store)))
|
|
(log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)"
|
|
id parent)
|
|
(incf orphans))))
|
|
store)))
|
|
(error ()
|
|
(log-message "ARCHIVIST: Memory store not available for orphan scan")))
|
|
(setf *archivist-last-gardener* (get-universal-time))
|
|
(list :broken-links broken-links :orphans orphans)))
|
|
|
|
(defun archivist-find-org-files (memex-dir)
|
|
"Recursively finds all .org files under memex-dir, up to 3 levels deep."
|
|
(let ((files nil))
|
|
(labels ((walk (dir depth)
|
|
(when (and (uiop:directory-exists-p dir) (< depth 3))
|
|
(handler-case
|
|
(dolist (entry (uiop:subdirectories dir))
|
|
(walk entry (1+ depth)))
|
|
(error ()))
|
|
(handler-case
|
|
(dolist (file (uiop:directory-files dir "*.org"))
|
|
(push (namestring file) files))
|
|
(error ())))))
|
|
(walk memex-dir 0))
|
|
files))
|
|
|
|
(defun archivist-extract-file-links (content)
|
|
"Extracts all =[[file:...]]= link targets from Org content.
|
|
Returns a list of link target strings."
|
|
(let ((links nil))
|
|
(cl-ppcre:do-register-groups (target)
|
|
("\\[\\[file:([^\\]]+)\\]\\[" content)
|
|
(unless (search "::" target) ;; skip internal anchors
|
|
(pushnew target links :test #'string=)))
|
|
;; Also handle bare [[file:target]] links
|
|
(cl-ppcre:do-register-groups (target)
|
|
("\\[\\[file:([^\\]]+)\\]\\]" content)
|
|
(unless (search "::" target)
|
|
(pushnew target links :test #'string=)))
|
|
links))
|
|
|
|
(defun archivist-run (action context)
|
|
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
|
and dispatches as needed. Called by the deterministic gate."
|
|
(declare (ignore action context))
|
|
(let ((now (get-universal-time)))
|
|
;; Scribe runs every 6 hours (21600 seconds)
|
|
(when (>= (- now *archivist-last-scribe*) 21600)
|
|
(ignore-errors (archivist-scribe-distill)))
|
|
;; Gardener runs every 24 hours
|
|
(when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*)
|
|
(ignore-errors
|
|
(let ((result (archivist-gardener-scan)))
|
|
(when (> (getf result :broken-links) 0)
|
|
(log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans"
|
|
(getf result :broken-links) (getf result :orphans)))))))
|
|
nil)
|
|
|
|
(defskill :passepartout-system-archivist
|
|
:priority 100
|
|
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
|
:deterministic #'archivist-run)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-system-archivist-tests
|
|
(:use :cl :passepartout)
|
|
(:export #:archivist-suite))
|
|
|
|
(in-package :passepartout-system-archivist-tests)
|
|
|
|
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
|
(fiveam:in-suite archivist-suite)
|
|
|
|
(fiveam:test test-extract-headlines
|
|
"Contract 1: archivist-extract-headlines parses Org content."
|
|
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
|
(headlines (archivist-extract-headlines content)))
|
|
(fiveam:is (listp headlines))
|
|
(fiveam:is (>= (length headlines) 1))))
|
|
|
|
(fiveam:test test-headline-to-filename
|
|
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
|
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
|
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
|
(fiveam:is (not (search ":" filename)))))
|
|
|
|
(fiveam:test test-archivist-create-note
|
|
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
|
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
|
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
|
(uiop:ensure-all-directories-exist (list tmp-dir))
|
|
(unwind-protect
|
|
(progn
|
|
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
|
"Expected note creation to return T")
|
|
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
|
"Expected file test_note.org to exist"))
|
|
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|