Amr Gharbeia
33993d2d73
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- BOUNCER-PRIVACY-TAGS → *DISPATCHER-PRIVACY-TAGS* - BOUNCER-SHELL-TIMEOUT → *DISPATCHER-SHELL-TIMEOUT* - BOUNCER-SHELL-MAX-OUTPUT → *DISPATCHER-SHELL-MAX-OUTPUT* - bouncer-privacy-tags docstrings → Dispatcher privacy tags - 'Bouncer' in log messages, docstrings, test descriptions - 'Bouncer Security Dispatcher' → 'Security Dispatcher'
417 lines
16 KiB
Org Mode
417 lines
16 KiB
Org Mode
#+TITLE: SKILL: Utils Org (org-skill-utils-org.org)
|
|
#+AUTHOR: Agent
|
|
#+FILETAGS: :skill:utils:org:
|
|
#+PROPERTY: header-args:lisp :tangle ../lisp/programming-org.lisp
|
|
|
|
* Overview
|
|
Structural manipulation tools for Org-mode files. This skill handles reading, writing, and modifying Org files at the AST level: finding headlines by ID or title, setting properties and TODO states, adding new headlines, generating UUIDs, and converting ASTs back to Org text. It also implements the privacy filter — when reading an Org file, it strips headlines tagged with ~@personal~ (or any tag in the Dispatcher's privacy tags) and rejects files with matching ~#+FILETAGS:~.
|
|
|
|
** Contract
|
|
|
|
1. (org-id-generate): returns a new UUID string.
|
|
2. (org-id-format id): ensures the ID has an "id:" prefix.
|
|
3. (org-property-set ast target-id property value): recursively sets a
|
|
property on a headline matching target-id. Returns T on success.
|
|
4. (org-todo-set ast target-id status): sets TODO status via
|
|
org-property-set.
|
|
5. (org-headline-add ast parent-id title): adds a new child headline.
|
|
6. (org-headline-find-by-id ast id): returns the subtree for a matching
|
|
headline ID.
|
|
|
|
* Implementation
|
|
|
|
** Package Context
|
|
#+begin_src lisp
|
|
(in-package :passepartout)
|
|
#+end_src
|
|
|
|
** Reading Files (with Privacy Filter)
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-filetags-extract (content)
|
|
"Extracts the list of tags from a #+FILETAGS: line."
|
|
(let ((lines (uiop:split-string content :separator '(#\Newline))))
|
|
(dolist (line lines)
|
|
(when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line))
|
|
(let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10))))
|
|
(return-from org-filetags-extract
|
|
(mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag)))
|
|
(uiop:split-string tag-str :separator '(#\space #\tab))))))))
|
|
nil)
|
|
|
|
#+end_src
|
|
** org-privacy-tag-p
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-privacy-tag-p (tags-list)
|
|
"Returns T if any tag in TAGS-LIST matches the Dispatcher's privacy tags."
|
|
(let ((privacy-tags (symbol-value (find-symbol "*DISPATCHER-PRIVACY-TAGS*" :passepartout))))
|
|
(when (and tags-list privacy-tags)
|
|
(some (lambda (tag)
|
|
(some (lambda (private-tag)
|
|
(string-equal (string-trim '(#\: #\space) tag)
|
|
(string-trim '(#\: #\space) private-tag)))
|
|
privacy-tags))
|
|
tags-list))))
|
|
|
|
#+end_src
|
|
** org-privacy-strip
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-privacy-strip (content)
|
|
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
|
Returns the filtered content as a string."
|
|
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(result-lines nil)
|
|
(skip-depth nil)
|
|
(current-tags nil)
|
|
(in-properties nil))
|
|
(dolist (line lines)
|
|
(cond
|
|
(skip-depth
|
|
;; We're inside a skipped subtree
|
|
(when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line))
|
|
(<= (length (string-trim '(#\Space) line)) skip-depth))
|
|
(setf skip-depth nil)))
|
|
((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line))
|
|
(setf in-properties t)
|
|
(push line result-lines))
|
|
((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line))
|
|
(setf in-properties nil)
|
|
(when current-tags
|
|
(when (org-privacy-tag-p (reverse current-tags))
|
|
(setf skip-depth
|
|
(length (car (last result-lines
|
|
(1+ (position-if
|
|
(lambda (l)
|
|
(uiop:string-prefix-p "*" (string-trim '(#\Space) l)))
|
|
(reverse result-lines))))))))
|
|
(setf current-tags nil))
|
|
(push line result-lines))
|
|
((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line)))
|
|
(let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6))))
|
|
(setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab))))
|
|
(push line result-lines))
|
|
(t
|
|
(push line result-lines))))
|
|
(format nil "~{~a~%~}" (nreverse result-lines))))
|
|
|
|
#+end_src
|
|
** org-read-file
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-read-file (filepath)
|
|
"Reads an Org file into a string, applying privacy filtering."
|
|
(let* ((raw (uiop:read-file-string filepath))
|
|
(filetags (org-filetags-extract raw)))
|
|
(if (org-privacy-tag-p filetags)
|
|
(progn
|
|
(log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags)
|
|
nil)
|
|
(org-privacy-strip raw))))
|
|
#+end_src
|
|
#+end_src
|
|
|
|
** Writing Files
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-write-file (filepath content)
|
|
"Writes content to an Org file."
|
|
(uiop:with-output-file (s filepath :if-exists :supersede)
|
|
(format s "~a" content)))
|
|
#+end_src
|
|
|
|
** ID Generation
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-id-generate ()
|
|
"Generates a new UUID for an Org node."
|
|
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
|
#+end_src
|
|
|
|
** ID Formatting
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-id-format (id)
|
|
"Ensures the ID has the 'id:' prefix."
|
|
(if (uiop:string-prefix-p "id:" id)
|
|
id
|
|
(format nil "id:~a" id)))
|
|
#+end_src
|
|
|
|
** Setting Properties (Recursive)
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-property-set (ast target-id property value)
|
|
"Recursively sets a property on a headline with a matching ID in the AST."
|
|
(let ((type (getf ast :type))
|
|
(props (getf ast :properties))
|
|
(contents (getf ast :contents)))
|
|
(when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
|
|
(setf (getf (getf ast :properties) property) value)
|
|
(return-from org-property-set t))
|
|
(dolist (child contents)
|
|
(when (listp child)
|
|
(when (org-property-set child target-id property value)
|
|
(return-from org-property-set t)))))
|
|
nil)
|
|
#+end_src
|
|
|
|
** Setting TODO Status
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-todo-set (ast target-id status)
|
|
"Sets the TODO status of a headline in the AST."
|
|
(org-property-set ast target-id :TODO status))
|
|
#+end_src
|
|
|
|
** Adding Headlines
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-headline-add (ast parent-id title)
|
|
"Adds a new headline as a child of the parent-id in the AST."
|
|
(let* ((type (getf ast :type))
|
|
(props (getf ast :properties))
|
|
(id (getf props :ID))
|
|
(contents (getf ast :contents)))
|
|
(when (and (eq type :HEADLINE) (string= id parent-id))
|
|
(let ((new-node (list :type :HEADLINE
|
|
:properties (list :ID (org-id-format (org-id-generate))
|
|
:TITLE title)
|
|
:contents nil)))
|
|
(setf (getf ast :contents) (append contents (list new-node)))
|
|
(return-from org-headline-add t)))
|
|
(dolist (child contents)
|
|
(when (listp child)
|
|
(when (org-headline-add child parent-id title)
|
|
(return-from org-headline-add t)))))
|
|
nil)
|
|
#+end_src
|
|
|
|
** Searching Headlines (by ID)
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-headline-find-by-id (ast id)
|
|
"Finds a headline by its ID in the AST."
|
|
(let ((props (getf ast :properties)))
|
|
(when (string= (getf props :ID) id)
|
|
(return-from org-headline-find-by-id ast))
|
|
(dolist (child (getf ast :contents))
|
|
(when (listp child)
|
|
(let ((found (org-headline-find-by-id child id)))
|
|
(when found (return-from org-headline-find-by-id found)))))
|
|
nil))
|
|
#+end_src
|
|
|
|
** Searching Headlines (by Title)
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-headline-find-by-title (ast title)
|
|
"Finds a headline by its title in the AST."
|
|
(let ((props (getf ast :properties)))
|
|
(when (string-equal (getf props :TITLE) title)
|
|
(return-from org-headline-find-by-title ast))
|
|
(dolist (child (getf ast :contents))
|
|
(when (listp child)
|
|
(let ((found (org-headline-find-by-title child title)))
|
|
(when found (return-from org-headline-find-by-title found)))))
|
|
nil))
|
|
#+end_src
|
|
|
|
** Subtree Extraction (from Org text)
|
|
|
|
Extracts a specific headline subtree from raw Org text by heading name.
|
|
Used by =context-skill-subtree= for targeted skill source loading.
|
|
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-subtree-extract (org-content heading-name)
|
|
"Extracts a subtree by heading name from Org text. Returns the subtree
|
|
content as a string (headline + body + children), or nil if not found."
|
|
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
|
(target-depth nil)
|
|
(in-target nil)
|
|
(result nil))
|
|
(loop for line in lines
|
|
for trimmed = (string-trim '(#\Space) line)
|
|
do (let ((depth (when (uiop:string-prefix-p "*" trimmed)
|
|
(length (subseq trimmed 0
|
|
(position-if (lambda (c) (not (char= c #\*)))
|
|
trimmed)))))
|
|
(headline-title (when (uiop:string-prefix-p "*" trimmed)
|
|
(string-trim '(#\* #\Space) trimmed))))
|
|
(when depth
|
|
(when (string-equal headline-title heading-name)
|
|
(setf target-depth depth in-target t))
|
|
(when (and in-target target-depth
|
|
(<= depth target-depth)
|
|
(not (string-equal headline-title heading-name)))
|
|
(return-from org-subtree-extract
|
|
(format nil "~{~a~^~%~}" (nreverse result)))))
|
|
(when in-target (push line result))))
|
|
(when result
|
|
(format nil "~{~a~^~%~}" (nreverse result)))))
|
|
|
|
#+end_src
|
|
** org-heading-list
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-heading-list (org-content)
|
|
"Returns a list of all top-level heading names in Org text."
|
|
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
|
(headings nil))
|
|
(dolist (line lines)
|
|
(let ((trimmed (string-trim '(#\Space) line)))
|
|
(when (uiop:string-prefix-p "* " trimmed)
|
|
(let ((title (string-trim '(#\* #\Space) trimmed)))
|
|
(unless (find title headings :test #'string-equal)
|
|
(push title headings))))))
|
|
(nreverse headings)))
|
|
#+end_src
|
|
#+end_src
|
|
|
|
** Text Modification in Org Files
|
|
Replaces text in Org files with verification. Used by =system-self-improve= for
|
|
surgical edits.
|
|
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-modify (filepath old-text new-text)
|
|
"Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
|
|
Returns T if OLD-TEXT was found and replaced, nil if not found."
|
|
(when (not (uiop:file-exists-p filepath))
|
|
(log-message "UTILS-ORG: org-modify: file not found: ~a" filepath)
|
|
(return-from org-modify nil))
|
|
(let* ((content (uiop:read-file-string filepath))
|
|
(pos (search old-text content :test #'string=)))
|
|
(unless pos
|
|
(log-message "UTILS-ORG: org-modify: text not found in ~a" filepath)
|
|
(return-from org-modify nil))
|
|
(let ((modified (cl-ppcre:regex-replace-all
|
|
(cl-ppcre:quote-meta-chars old-text)
|
|
content new-text)))
|
|
(org-write-file filepath modified)
|
|
(log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text))
|
|
t)))
|
|
#+end_src
|
|
|
|
** AST to Org text conversion
|
|
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
|
#+begin_src lisp
|
|
(defun org-ast-render (ast &key (depth 1))
|
|
"Converts a plist AST node back to Org text.
|
|
AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
|
:contents (child-ast ...))"
|
|
(let* ((type (getf ast :TYPE))
|
|
(props (getf ast :properties))
|
|
(title (or (getf props :TITLE) "Untitled"))
|
|
(tags (getf props :TAGS))
|
|
(todo (getf props :TODO-STATE))
|
|
(children (getf ast :contents))
|
|
(raw-content (getf ast :raw-content))
|
|
(stars (make-string depth :initial-element #\*))
|
|
(output ""))
|
|
(unless (eq type :HEADLINE)
|
|
(return-from org-ast-render (or raw-content "")))
|
|
;; Headline
|
|
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
|
(when 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
|
|
(setf output (concatenate 'string output (string #\Newline))))
|
|
;; Property drawer
|
|
(setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline)))
|
|
(loop for (k v) on props by #'cddr
|
|
do (unless (or (eq k :TITLE) (eq k :TAGS))
|
|
(setf output (concatenate 'string output
|
|
(format nil ":~a: ~a~%" k v)))))
|
|
(setf output (concatenate 'string output ":END:" (string #\Newline)))
|
|
;; Content
|
|
(when raw-content
|
|
(setf output (concatenate 'string output raw-content (string #\Newline))))
|
|
;; Children
|
|
(dolist (child children)
|
|
(when (listp child)
|
|
(setf output (concatenate 'string output
|
|
(org-ast-render child :depth (1+ depth))))))
|
|
output))
|
|
#+end_src
|
|
|
|
** Skill Registration
|
|
#+begin_src lisp
|
|
(defskill :passepartout-programming-org
|
|
:priority 100
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
|
#+end_src
|
|
|
|
* Test Suite
|
|
Verification of the structural manipulation for Org-mode files and their AST representation.
|
|
#+begin_src 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))
|
|
|
|
(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
|
|
"Contract 1: org-id-generate returns unique UUID strings."
|
|
(let ((id1 (org-id-generate))
|
|
(id2 (org-id-generate)))
|
|
(is (plusp (length id1)))
|
|
(is (not (string= id1 id2)))))
|
|
|
|
(test id-format
|
|
"Contract 2: org-id-format ensures 'id:' prefix."
|
|
(let ((formatted (org-id-format "abc12345")))
|
|
(is (search "id:" formatted))))
|
|
|
|
(test property-setter
|
|
"Contract 3: org-property-set modifies a property on a headline."
|
|
(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
|
|
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
|
(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"))))
|
|
|
|
(test test-org-headline-add
|
|
"Contract 5: org-headline-add inserts a child headline."
|
|
(let* ((ast (list :type :HEADLINE
|
|
:properties (list :ID "root" :TITLE "Root")
|
|
:contents nil)))
|
|
(is (eq t (org-headline-add ast "root" "New Child")))
|
|
(is (= 1 (length (getf ast :contents))))
|
|
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
|
|
|
(test test-org-headline-find-by-id
|
|
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
|
(let* ((ast (list :type :HEADLINE
|
|
:properties (list :ID "root" :TITLE "Root")
|
|
:contents
|
|
(list (list :type :HEADLINE
|
|
:properties (list :ID "child1" :TITLE "Child"))
|
|
(list :type :HEADLINE
|
|
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
|
(let ((found (org-headline-find-by-id ast "child2")))
|
|
(is (not (null found)))
|
|
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
|
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
|
(is (null missing) "Missing ID should return nil"))))
|
|
#+end_src |