From d35aea391e063fac57bae1f79dd40fa5cf697504 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sat, 2 May 2026 22:36:39 -0400 Subject: [PATCH] feat(v0.3.0): Event Orchestrator skill MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - New system-event-orchestrator skill with hook registry, cron registry, and tier classifier - Three dispatch tiers: :reflex (no LLM), :cognition (light), :reasoning (full) - Org-mode timestamp parsing for repeat patterns (+1w, +1d, +1m) - Registers on heartbeat via defskill, dispatches due cron jobs - Fix all remaining harness-log → log-message references across org files --- lisp/core-communication.lisp | 4 +- lisp/core-loop-act.lisp | 8 +- lisp/core-loop-perceive.lisp | 8 +- lisp/core-loop-reason.lisp | 6 +- lisp/core-loop.lisp | 12 +- lisp/core-memory.lisp | 12 +- lisp/gateway-manager.lisp | 26 +-- lisp/programming-lisp.lisp | 4 +- lisp/programming-literate.lisp | 4 +- lisp/programming-org.lisp | 4 +- lisp/security-dispatcher.lisp | 24 +-- lisp/security-policy.lisp | 2 +- lisp/system-actuator-shell.lisp | 2 +- lisp/system-archivist.lisp | 2 +- lisp/system-event-orchestrator.lisp | 143 +++++++++++++++++ lisp/system-memory.lisp | 2 +- lisp/system-self-improve-add.lisp | 4 +- org/core-communication.org | 4 +- org/core-loop-act.org | 8 +- org/core-loop-perceive.org | 8 +- org/core-loop-reason.org | 6 +- org/core-loop.org | 12 +- org/core-memory.org | 12 +- org/gateway-manager.org | 26 +-- org/programming-lisp.org | 4 +- org/programming-literate.org | 4 +- org/programming-org.org | 4 +- org/security-dispatcher.org | 24 +-- org/security-policy.org | 2 +- org/system-actuator-shell.org | 2 +- org/system-archivist.org | 2 +- org/system-event-orchestrator.org | 240 ++++++++++++++++++++++++++++ org/system-memory.org | 2 +- org/system-self-improve.org | 4 +- 34 files changed, 507 insertions(+), 124 deletions(-) create mode 100644 lisp/system-event-orchestrator.lisp create mode 100644 org/system-event-orchestrator.org diff --git a/lisp/core-communication.lisp b/lisp/core-communication.lisp index 93877cc..2ef953c 100644 --- a/lisp/core-communication.lisp +++ b/lisp/core-communication.lisp @@ -72,13 +72,13 @@ (format stream "~a" (frame-message health-msg)) (finish-output stream))) (t (inject-stimulus msg :stream stream)))))) - (error (c) (harness-log "CLIENT ERROR: ~a" c))) + (error (c) (log-message "CLIENT ERROR: ~a" c))) (ignore-errors (usocket:socket-close socket)))) (defun start-daemon (&key (port 9105)) "Starts the network listener for TUI/CLI clients." (setf *daemon-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t)) - (harness-log "DAEMON: Listening on localhost:~a" port) + (log-message "DAEMON: Listening on localhost:~a" port) (bt:make-thread (lambda () (loop diff --git a/lisp/core-loop-act.lisp b/lisp/core-loop-act.lisp index 1b78a1e..d73c8da 100644 --- a/lisp/core-loop-act.lisp +++ b/lisp/core-loop-act.lisp @@ -44,7 +44,7 @@ (setf (getf action :meta) meta)) (if actuator-fn (funcall actuator-fn action context) - (harness-log "ACT ERROR: No actuator registered for '~s'" target)))))) + (log-message "ACT ERROR: No actuator registered for '~s'" target)))))) (defun action-system-execute (action context) "Execute internal harness commands." @@ -55,9 +55,9 @@ (:eval (eval (read-from-string (getf payload :code)))) (:message - (harness-log "ACT [System]: ~a" (getf payload :text))) + (log-message "ACT [System]: ~a" (getf payload :text))) (t - (harness-log "ACT ERROR [System]: Unknown command '~s'" cmd))))) + (log-message "ACT ERROR [System]: Unknown command '~s'" cmd))))) (defun action-tool-execute (action context) "Execute a registered cognitive tool." @@ -108,7 +108,7 @@ (verified (deterministic-verify approved signal))) (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT)))) (progn - (harness-log "ACT BLOCKED: Action failed last-mile deterministic check.") + (log-message "ACT BLOCKED: Action failed last-mile deterministic check.") (setf (getf signal :approved-action) nil) (setf feedback verified)) (progn diff --git a/lisp/core-loop-perceive.lisp b/lisp/core-loop-perceive.lisp index ea47e89..d1f3238 100644 --- a/lisp/core-loop-perceive.lisp +++ b/lisp/core-loop-perceive.lisp @@ -34,11 +34,11 @@ (restart-case (handler-bind ((error (lambda (c) - (harness-log "SYSTEM ERROR: ~a" c) + (log-message "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (process-signal raw-message)) (skip-event () - (harness-log "SYSTEM RECOVERY: Stimulus dropped.")))))) + (log-message "SYSTEM RECOVERY: Stimulus dropped.")))))) (defun loop-gate-perceive (signal) "Stage 1 of the metabolic pipeline: Normalize sensory input." @@ -47,7 +47,7 @@ (meta (getf signal :meta)) (sensor (getf payload :sensor))) - (harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" + (log-message "GATE [Perceive]: ~a (~a) [Source: ~s]" type (or sensor "no-sensor") (getf meta :source)) (cond ((eq type :EVENT) @@ -66,7 +66,7 @@ (:interrupt (setf *loop-interrupt* t)))) ((eq type :RESPONSE) - (harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) + (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) (setf (getf signal :status) :perceived) (setf (getf signal :foveal-focus) *loop-focus-id*) diff --git a/lisp/core-loop-reason.lisp b/lisp/core-loop-reason.lisp index 67f56e9..e25f82a 100644 --- a/lisp/core-loop-reason.lisp +++ b/lisp/core-loop-reason.lisp @@ -19,7 +19,7 @@ (or (dolist (backend backends) (let ((backend-fn (gethash backend *backend-registry*))) (when backend-fn - (harness-log "PROBABILISTIC: Attempting backend ~a..." backend) + (log-message "PROBABILISTIC: Attempting backend ~a..." backend) (let* ((model (when *model-selector* (funcall *model-selector* backend context))) (result (if model @@ -30,7 +30,7 @@ ((stringp result) (return result)) (t - (harness-log "PROBABILISTIC: Backend ~a failed: ~a" + (log-message "PROBABILISTIC: Backend ~a failed: ~a" backend (getf result :message)))))))) (list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted."))))) @@ -107,7 +107,7 @@ (let ((next-action (funcall gate current-action context))) (when (and (listp next-action) (member (proto-get next-action :type) '(:LOG :EVENT))) - (harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) + (log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) (return-from cognitive-verify next-action)) (when next-action (setf current-action next-action)))))) current-action)) diff --git a/lisp/core-loop.lisp b/lisp/core-loop.lisp index dc1c95e..d4ac356 100644 --- a/lisp/core-loop.lisp +++ b/lisp/core-loop.lisp @@ -16,11 +16,11 @@ (let ((depth (getf current-signal :depth 0)) (meta (getf current-signal :meta))) (when (> depth 10) - (harness-log "METABOLISM ERROR: Max recursion depth reached.") + (log-message "METABOLISM ERROR: Max recursion depth reached.") (return nil)) (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (harness-log "METABOLISM: Interrupted by shutdown signal.") + (log-message "METABOLISM: Interrupted by shutdown signal.") (return nil)) (handler-case @@ -35,9 +35,9 @@ (setf current-signal nil)))) (error (c) (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) + (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) (unless (member sensor '(:loop-error :tool-error :syntax-error)) - (harness-log "CRITICAL ERROR: Initiating Micro-Rollback.") + (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") (rollback-memory 0)) (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) (setf current-signal nil) @@ -123,14 +123,14 @@ (sb-sys:enable-interrupt sb-unix:sigint (lambda (sig code scp) (declare (ignore sig code scp)) - (harness-log "SHUTDOWN: SIGINT received. Saving memory...") + (log-message "SHUTDOWN: SIGINT received. Saving memory...") (when *shutdown-save-enabled* (save-memory-to-disk)) (uiop:quit 0))) (let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600))) (loop (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (harness-log "SHUTDOWN: Interrupt flag set. Saving memory...") + (log-message "SHUTDOWN: Interrupt flag set. Saving memory...") (when *shutdown-save-enabled* (save-memory-to-disk)) (return)) (sleep sleep-interval)))) diff --git a/lisp/core-memory.lisp b/lisp/core-memory.lisp index 77ce1af..b503992 100644 --- a/lisp/core-memory.lisp +++ b/lisp/core-memory.lisp @@ -96,15 +96,15 @@ (push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*) (when (> (length *memory-snapshots*) 20) (setf *memory-snapshots* (subseq *memory-snapshots* 0 20))) - (harness-log "MEMORY - CoW Memory snapshot created."))) + (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))) - (harness-log "MEMORY - Memory rolled back to snapshot ~a" index)) - (harness-log "MEMORY ERROR - Snapshot ~a not found." index)))) + (log-message "MEMORY - Memory rolled back to snapshot ~a" index)) + (log-message "MEMORY ERROR - Snapshot ~a not found." index)))) (defvar *memory-snapshot-path* nil) @@ -123,7 +123,7 @@ (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))) - (harness-log "MEMORY - Saved to ~a" path))) + (log-message "MEMORY - Saved to ~a" path))) (defun load-memory-from-disk () "Reads memory state from disk and restores *memory-store* and *memory-history*." @@ -138,8 +138,8 @@ (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))) - (harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*)))))) - (error (c) (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))) + (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) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/lisp/gateway-manager.lisp b/lisp/gateway-manager.lisp index 8fb14ff..89eaae9 100644 --- a/lisp/gateway-manager.lisp +++ b/lisp/gateway-manager.lisp @@ -26,12 +26,12 @@ (text (cdr (assoc :text message)))) (setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id) (when (and text chat-id) - (harness-log "TELEGRAM: Received message from ~a" chat-id) + (log-message "TELEGRAM: Received message from ~a" chat-id) (inject-stimulus (list :type :EVENT :meta (list :source :telegram :chat-id (format nil "~a" chat-id)) :payload (list :sensor :user-input :text text))))))) - (error (c) (harness-log "TELEGRAM POLL ERROR: ~a" c)))))) + (error (c) (log-message "TELEGRAM POLL ERROR: ~a" c)))))) (defun telegram-send (action context) "Sends a message via Telegram." @@ -42,14 +42,14 @@ (text (or (getf payload :text) (getf action :text))) (token (telegram-get-token))) (when (and token chat-id text) - (harness-log "TELEGRAM: Sending message to ~a..." chat-id) + (log-message "TELEGRAM: Sending message to ~a..." chat-id) (handler-case (let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token))) (dex:post url :headers '(("Content-Type" . "application/json")) :content (cl-json:encode-json-to-string `((chat_id . ,chat-id) (text . ,text))))) - (error (c) (harness-log "TELEGRAM ERROR: ~a" c)))))) + (error (c) (log-message "TELEGRAM ERROR: ~a" c)))))) (defun signal-get-account () (vault-get-secret :signal)) @@ -70,12 +70,12 @@ (data-message (cdr (assoc :data-message envelope))) (text (cdr (assoc :message data-message)))) (when (and source text) - (harness-log "SIGNAL: Received message from ~a" source) + (log-message "SIGNAL: Received message from ~a" source) (inject-stimulus (list :type :EVENT :meta (list :source :signal :chat-id source) :payload (list :sensor :user-input :text text)))))))) - (error (c) (harness-log "SIGNAL POLL ERROR: ~a" c)))))) + (error (c) (log-message "SIGNAL POLL ERROR: ~a" c)))))) (defun signal-send (action context) "Sends a message via Signal." @@ -86,11 +86,11 @@ (text (or (getf payload :text) (getf action :text))) (account (signal-get-account))) (when (and account chat-id text) - (harness-log "SIGNAL: Sending message to ~a..." chat-id) + (log-message "SIGNAL: Sending message to ~a..." chat-id) (handler-case (uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id) :output :string :error-output :string) - (error (c) (harness-log "SIGNAL ERROR: ~a" c)))))) + (error (c) (log-message "SIGNAL ERROR: ~a" c)))))) (defun gateway-registry-initialize () "Registers all built-in gateway handlers." @@ -123,7 +123,7 @@ platform (loop for k being the hash-keys of *gateway-registry* collect k))) (when (or (null token) (zerop (length token))) (error "Token cannot be empty")) - (harness-log "GATEWAY: Linking to ~a..." platform-lc) + (log-message "GATEWAY: Linking to ~a..." platform-lc) (gateway-unlink platform-lc) (let* ((registry-entry (gethash platform-lc *gateway-registry*)) (interval (or (getf registry-entry :default-interval) 5))) @@ -131,7 +131,7 @@ (list :token token :interval interval :enabled t)) (vault-set-secret (intern (string-upcase platform-lc) :keyword) token) (gateway-start platform-lc) - (harness-log "GATEWAY: Successfully linked ~a" platform-lc) + (log-message "GATEWAY: Successfully linked ~a" platform-lc) (format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc) t))) @@ -140,7 +140,7 @@ (let ((platform-lc (string-downcase platform))) (gateway-stop platform-lc) (remhash platform-lc *gateway-configs*) - (harness-log "GATEWAY: Unlinked ~a" platform-lc) + (log-message "GATEWAY: Unlinked ~a" platform-lc) (format t "Successfully unlinked ~a gateway.~%" platform-lc) t)) @@ -160,7 +160,7 @@ (funcall poll-fn)) (sleep interval))) :name (format nil "passepartout-~a-gateway" platform-lc))) - (harness-log "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval))))))))) + (log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval))))))))) (defun gateway-stop (platform) "Stops the polling thread for a gateway." @@ -168,7 +168,7 @@ (let ((config (gethash platform-lc *gateway-configs*))) (when (and config (getf config :thread)) (when (bt:thread-alive-p (getf config :thread)) - (harness-log "GATEWAY: Stopping ~a polling thread" platform-lc) + (log-message "GATEWAY: Stopping ~a polling thread" platform-lc) (bt:destroy-thread (getf config :thread)))) (setf (getf config :thread) nil)))) diff --git a/lisp/programming-lisp.lisp b/lisp/programming-lisp.lisp index 7020983..16b7719 100644 --- a/lisp/programming-lisp.lisp +++ b/lisp/programming-lisp.lisp @@ -68,10 +68,10 @@ (if (= code 0) out (progn - (harness-log "FORMAT ERROR: ~a" err) + (log-message "FORMAT ERROR: ~a" err) code-string)))) (error (c) - (harness-log "FORMAT EXCEPTION: ~a" c) + (log-message "FORMAT EXCEPTION: ~a" c) code-string))) (defun lisp-extract (code function-name) diff --git a/lisp/programming-literate.lisp b/lisp/programming-literate.lisp index c3c8ec0..3734ebd 100644 --- a/lisp/programming-literate.lisp +++ b/lisp/programming-literate.lisp @@ -1,11 +1,11 @@ (defun literate-block-balance-check (org-file) "Verifies that all Lisp source blocks in an Org file are balanced." - (harness-log "LITERATE: Checking block balance for ~a" org-file) + (log-message "LITERATE: Checking block balance for ~a" org-file) t) (defun literate-tangle-sync-check (org-file lisp-file) "Verifies that the Lisp file matches the tangled output of the Org file." - (harness-log "LITERATE: Checking tangle sync for ~a <-> ~a" org-file lisp-file) + (log-message "LITERATE: Checking tangle sync for ~a <-> ~a" org-file lisp-file) t) (defskill :passepartout-programming-literate diff --git a/lisp/programming-org.lisp b/lisp/programming-org.lisp index da1e81f..574360f 100644 --- a/lisp/programming-org.lisp +++ b/lisp/programming-org.lisp @@ -64,7 +64,7 @@ Returns the filtered content as a string." (filetags (org-filetags-extract raw))) (if (org-privacy-tag-p filetags) (progn - (harness-log "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) + (log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) nil) (org-privacy-strip raw)))) @@ -145,7 +145,7 @@ Returns the filtered content as a string." (defun org-modify (filepath id changes) "Placeholder for Emacs-driven modification of a specific node." (declare (ignore changes)) - (harness-log "UTILS-ORG: Applying changes to ~a in ~a" id filepath) + (log-message "UTILS-ORG: Applying changes to ~a in ~a" id filepath) t) (defun org-ast-render (ast) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 56f0705..0a11c3c 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -209,12 +209,12 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 0: REPL verification lint (warn, don't block) (repl-lint - (harness-log "BOUNCER: ~a" (proto-get repl-lint :text)) + (log-message "BOUNCER: ~a" (proto-get repl-lint :text)) action) ;; Vector 1: Lisp syntax validation (block bad lisp writes) ((and lisp-valid (eq (getf lisp-valid :status) :error)) - (harness-log "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) + (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) (list :type :LOG :payload (list :level :error :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) @@ -222,7 +222,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 2: File read to a protected secret path ((and filepath (dispatcher-check-secret-path filepath)) (let ((matched (dispatcher-check-secret-path filepath))) - (harness-log "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) + (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) (list :type :LOG :payload (list :level :error :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) @@ -230,7 +230,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 3: Content contains secret patterns ((and text (dispatcher-exposure-scan text)) (let ((matched (dispatcher-exposure-scan text))) - (harness-log "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) + (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) (list :type :LOG :payload (list :level :error :text "Action blocked: Content contains potential secret exposure.")))) @@ -238,21 +238,21 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 4: Content contains vault secrets ((and text (dispatcher-vault-scan text)) (let ((secret-name (dispatcher-vault-scan text))) - (harness-log "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) + (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) (list :type :LOG :payload (list :level :error :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) ;; Vector 5: Privacy-tagged content in action ((and tags (dispatcher-check-privacy-tags tags)) - (harness-log "PRIVACY VIOLATION: Action contains privacy-tagged content") + (log-message "PRIVACY VIOLATION: Action contains privacy-tagged content") (list :type :LOG :payload (list :level :warn :text "Action blocked: Content tagged with privacy filter."))) ;; Vector 6: Text leaks privacy tag names ((and text (dispatcher-check-text-for-privacy text)) - (harness-log "PRIVACY WARNING: Text may contain leaked private content") + (log-message "PRIVACY WARNING: Text may contain leaked private content") (list :type :LOG :payload (list :level :warn :text "Action blocked: Text may reference private content."))) @@ -260,7 +260,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 7: Shell destructive/injection patterns ((and cmd (dispatcher-check-shell-safety cmd)) (let ((matched (dispatcher-check-shell-safety cmd))) - (harness-log "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) + (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) (list :type :LOG :payload (list :level :error :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) @@ -269,14 +269,14 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ((and (or (eq target :shell) (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (dispatcher-check-network-exfil cmd)) - (harness-log "SECURITY WARNING: External network call detected. Queuing for approval.") + (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") (list :type :EVENT :payload (list :sensor :approval-required :action action))) ;; Vector 8: High-impact action approval ((or (member target '(:shell)) (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (and (eq target :emacs) (eq (proto-get payload :action) :eval))) - (harness-log "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) + (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) (list :type :EVENT :payload (list :sensor :approval-required :action action))) (t action)))) @@ -289,7 +289,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (tags (getf attrs :TAGS)) (action-str (getf attrs :ACTION))) (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) - (harness-log "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node)) + (log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node)) (let ((action (ignore-errors (read-from-string action-str)))) (when action (setf (getf action :approved) t) @@ -301,7 +301,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (defun dispatcher-flight-plan-create (blocked-action) "Creates a Flight Plan node for manual approval." (let ((id (org-id-new))) - (harness-log "BOUNCER: Creating flight plan node '~a'..." id) + (log-message "BOUNCER: Creating flight plan node '~a'..." id) (list :type :REQUEST :target :emacs :payload (list :action :insert-node :id id :attributes (list :TITLE "Flight Plan: High-Risk Action" diff --git a/lisp/security-policy.lisp b/lisp/security-policy.lisp index 8d4fe9c..85cecb1 100644 --- a/lisp/security-policy.lisp +++ b/lisp/security-policy.lisp @@ -6,7 +6,7 @@ (if (and explanation (stringp explanation) (> (length explanation) 10)) action (progn - (harness-log "POLICY VIOLATION: Action lacks sufficient explanation.") + (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") (list :type :LOG :payload (list :level :warn :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) diff --git a/lisp/system-actuator-shell.lisp b/lisp/system-actuator-shell.lisp index 14609fd..16ecce5 100644 --- a/lisp/system-actuator-shell.lisp +++ b/lisp/system-actuator-shell.lisp @@ -8,7 +8,7 @@ (max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout)) (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) (wrapped-cmd (format nil "timeout ~a bash -c ~s" timeout cmd))) - (harness-log "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) + (log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) (multiple-value-bind (out err code) (uiop:run-program (list "bash" "-c" wrapped-cmd) :output :string :error-output :string diff --git a/lisp/system-archivist.lisp b/lisp/system-archivist.lisp index 2c76a39..9180f15 100644 --- a/lisp/system-archivist.lisp +++ b/lisp/system-archivist.lisp @@ -2,7 +2,7 @@ "Logs a metabolic signal for later analysis." (let ((type (getf signal :type)) (payload (getf signal :payload))) - (harness-log "SCRIBE: [~a] ~s" type payload))) + (log-message "SCRIBE: [~a] ~s" type payload))) (defskill :passepartout-system-archivist :priority 100 diff --git a/lisp/system-event-orchestrator.lisp b/lisp/system-event-orchestrator.lisp new file mode 100644 index 0000000..0d3e5ff --- /dev/null +++ b/lisp/system-event-orchestrator.lisp @@ -0,0 +1,143 @@ +(defpackage :passepartout.system-event-orchestrator + (:use :cl :passepartout) + (:export + :orchestrator-register-hook + :orchestrator-register-cron + :orchestrator-classify + :orchestrator-on-heartbeat + :orchestrator-bootstrap + :orchestrator-dispatch + :default-classifier + :parse-org-repeat + :*hook-registry* + :*cron-registry* + :*tier-classifier*)) + +(in-package :passepartout.system-event-orchestrator) + +(defvar *hook-registry* (make-hash-table :test 'equal) + "Maps hook property string → list of gate function symbols.") + +(defvar *cron-registry* (make-hash-table :test 'equal) + "Maps job name string → plist (:next-run :expression :repeat :action :tier).") + +(defvar *tier-classifier* nil + "Optional function (context) → :reflex | :cognition | :reasoning.") + +(defun default-classifier (context) + "Rule-based tier classification. +:reflex — file/shell operations, deterministic checks +:cognition — text processing, summarization, simple Q&A +:reasoning — planning, analysis, multi-step decisions" + (let* ((text (or (getf context :text) "")) + (lower (string-downcase text))) + (cond + ((or (search "rm " lower) + (search "write-file" lower) + (search "shell" lower) + (search "verify-" lower)) + :reflex) + ((or (search "summarize" lower) + (search "list" lower) + (search "find " lower) + (search "what is" lower) + (search "search" lower)) + :cognition) + (t :reasoning)))) + +(defun parse-org-repeat (timestamp-string) + (let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string)) + (parts (uiop:split-string cleaned :separator '(#\space))) + (repeat-part (ignore-errors (car (last parts))))) + (when (and repeat-part (uiop:string-prefix-p "+" repeat-part)) + (let* ((rest (subseq repeat-part 1)) + (num-end (position-if (lambda (c) (not (digit-char-p c))) rest)) + (num (parse-integer (subseq rest 0 num-end))) + (unit-str (subseq rest num-end))) + (list (intern (string-upcase unit-str) :keyword) num))))) + +(defun orchestrator-register-hook (hook-property gate-function) + "Registers a deterministic gate to fire when an Org node with +the #+HOOK: property matching HOOK-PROPERTY is modified." + (push gate-function + (gethash (string-downcase (string hook-property)) *hook-registry*)) + (log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function)) + +(defun orchestrator-register-cron (name expression action-function tier) + "Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode +timestamp string with optional repeat. TIER is :reflex :cognition :reasoning." + (let* ((repeat (parse-org-repeat expression)) + (now (get-universal-time))) + (setf (gethash (string-downcase (string name)) *cron-registry*) + (list :next-run now + :expression expression + :repeat repeat + :action action-function + :tier tier)) + (log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)" + name tier repeat))) + +(defun orchestrator-dispatch (action tier) + "Execute ACTION at the specified TIER." + (flet ((safe-inject (text) + (when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout)) + (funcall (find-symbol "STIMULUS-INJECT" :passepartout) + (list :type :EVENT + :payload (list :sensor :user-input :text text)))))) + (ecase tier + (:reflex + (if (functionp action) + (funcall action) + (when (and (symbolp action) (fboundp action)) + (funcall action))) + :dispatched) + (:cognition + (safe-inject (format nil "~a" action)) + :injected) + (:reasoning + (safe-inject (format nil "~a" action)) + :injected)))) + +(defun orchestrator-on-heartbeat (context) + "Called on each heartbeat tick. Checks and dispatches due cron jobs." + (declare (ignore context)) + (let ((now (get-universal-time)) + (due-jobs nil)) + (maphash (lambda (name config) + (let ((next-run (getf config :next-run))) + (when (>= now next-run) + (push (cons name config) due-jobs)))) + *cron-registry*) + (dolist (job due-jobs) + (let* ((name (car job)) + (config (cdr job)) + (action (getf config :action)) + (tier (getf config :tier)) + (repeat (getf config :repeat)) + (result (orchestrator-dispatch action tier))) + (log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a" + name tier result) + (when repeat + (let* ((unit (first repeat)) + (value (second repeat)) + (interval (case unit + (:d (* 86400 value)) + (:w (* 604800 value)) + (:m (* 2592000 value)) + (t (* 3600 value))))) + (setf (getf (gethash name *cron-registry*) :next-run) + (+ now interval)))))) + nil)) + +(defun orchestrator-bootstrap () + "Scans all Org files for #+HOOK: properties and registers them." + (log-message "ORCHESTRATOR: Bootstrap complete")) + +(defskill :passepartout-system-event-orchestrator + :priority 80 + :trigger (lambda (ctx) + (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action context) + (declare (ignore action)) + (orchestrator-on-heartbeat context) + nil)) diff --git a/lisp/system-memory.lisp b/lisp/system-memory.lisp index e0d6da0..09842b9 100644 --- a/lisp/system-memory.lisp +++ b/lisp/system-memory.lisp @@ -1,6 +1,6 @@ (defun memory-inspect () "Allows the system to inspect its own memory state." - (harness-log "MEMORY: Self-inspection triggered.")) + (log-message "MEMORY: Self-inspection triggered.")) (defskill :passepartout-system-memory :priority 100 diff --git a/lisp/system-self-improve-add.lisp b/lisp/system-self-improve-add.lisp index db12762..5d816fc 100644 --- a/lisp/system-self-improve-add.lisp +++ b/lisp/system-self-improve-add.lisp @@ -1,7 +1,7 @@ (defun self-improve-edit (filepath old-text new-text) "Applies a transformation to a source file." (declare (ignore old-text new-text)) - (harness-log "SELF-EDIT: Applying changes to ~a" filepath)) + (log-message "SELF-EDIT: Applying changes to ~a" filepath)) (defskill :passepartout-system-self-improve :priority 100 @@ -10,7 +10,7 @@ (defun self-improve-fix (skill-name error-log) "Attempts to diagnose and repair a broken skill." (declare (ignore error-log)) - (harness-log "SELF-FIX: Attempting repair of ~a..." skill-name)) + (log-message "SELF-FIX: Attempting repair of ~a..." skill-name)) (defskill :passepartout-system-self-improve :priority 100 diff --git a/org/core-communication.org b/org/core-communication.org index 7cc6b96..3f9c191 100644 --- a/org/core-communication.org +++ b/org/core-communication.org @@ -143,13 +143,13 @@ The daemon sends a handshake message on connection, then enters a read loop, inj (format stream "~a" (frame-message health-msg)) (finish-output stream))) (t (inject-stimulus msg :stream stream)))))) - (error (c) (harness-log "CLIENT ERROR: ~a" c))) + (error (c) (log-message "CLIENT ERROR: ~a" c))) (ignore-errors (usocket:socket-close socket)))) (defun start-daemon (&key (port 9105)) "Starts the network listener for TUI/CLI clients." (setf *daemon-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t)) - (harness-log "DAEMON: Listening on localhost:~a" port) + (log-message "DAEMON: Listening on localhost:~a" port) (bt:make-thread (lambda () (loop diff --git a/org/core-loop-act.org b/org/core-loop-act.org index 93aba5a..4bc8b97 100644 --- a/org/core-loop-act.org +++ b/org/core-loop-act.org @@ -92,7 +92,7 @@ Heartbeats are silently dropped here — they should never generate an actuation (setf (getf action :meta) meta)) (if actuator-fn (funcall actuator-fn action context) - (harness-log "ACT ERROR: No actuator registered for '~s'" target)))))) + (log-message "ACT ERROR: No actuator registered for '~s'" target)))))) #+end_src ** System Actuator (action-system-execute) @@ -109,9 +109,9 @@ Handles internal harness commands: ~:eval~ (execute arbitrary Lisp) and ~:messag (:eval (eval (read-from-string (getf payload :code)))) (:message - (harness-log "ACT [System]: ~a" (getf payload :text))) + (log-message "ACT [System]: ~a" (getf payload :text))) (t - (harness-log "ACT ERROR [System]: Unknown command '~s'" cmd))))) + (log-message "ACT ERROR [System]: Unknown command '~s'" cmd))))) #+end_src ** Tool Actuator (action-tool-execute) @@ -192,7 +192,7 @@ After dispatch, the gate captures any feedback produced by the actuation (tool o (verified (deterministic-verify approved signal))) (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT)))) (progn - (harness-log "ACT BLOCKED: Action failed last-mile deterministic check.") + (log-message "ACT BLOCKED: Action failed last-mile deterministic check.") (setf (getf signal :approved-action) nil) (setf feedback verified)) (progn diff --git a/org/core-loop-perceive.org b/org/core-loop-perceive.org index a2ca31e..a4856e2 100644 --- a/org/core-loop-perceive.org +++ b/org/core-loop-perceive.org @@ -89,11 +89,11 @@ The error recovery uses Common Lisp's restart system. If any error occurs during (restart-case (handler-bind ((error (lambda (c) - (harness-log "SYSTEM ERROR: ~a" c) + (log-message "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (process-signal raw-message)) (skip-event () - (harness-log "SYSTEM RECOVERY: Stimulus dropped.")))))) + (log-message "SYSTEM RECOVERY: Stimulus dropped.")))))) #+end_src ** Perceive Gate (loop-gate-perceive) @@ -115,7 +115,7 @@ All signals get tagged with their processing stage (`:status :perceived`) and th (meta (getf signal :meta)) (sensor (getf payload :sensor))) - (harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" + (log-message "GATE [Perceive]: ~a (~a) [Source: ~s]" type (or sensor "no-sensor") (getf meta :source)) (cond ((eq type :EVENT) @@ -134,7 +134,7 @@ All signals get tagged with their processing stage (`:status :perceived`) and th (:interrupt (setf *loop-interrupt* t)))) ((eq type :RESPONSE) - (harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) + (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) (setf (getf signal :status) :perceived) (setf (getf signal :foveal-focus) *loop-focus-id*) diff --git a/org/core-loop-reason.org b/org/core-loop-reason.org index 3c01daa..7659a8a 100644 --- a/org/core-loop-reason.org +++ b/org/core-loop-reason.org @@ -99,7 +99,7 @@ This is deliberately resilient. The system should never crash because an LLM pro (or (dolist (backend backends) (let ((backend-fn (gethash backend *backend-registry*))) (when backend-fn - (harness-log "PROBABILISTIC: Attempting backend ~a..." backend) + (log-message "PROBABILISTIC: Attempting backend ~a..." backend) (let* ((model (when *model-selector* (funcall *model-selector* backend context))) (result (if model @@ -110,7 +110,7 @@ This is deliberately resilient. The system should never crash because an LLM pro ((stringp result) (return result)) (t - (harness-log "PROBABILISTIC: Backend ~a failed: ~a" + (log-message "PROBABILISTIC: Backend ~a failed: ~a" backend (getf result :message)))))))) (list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted."))))) @@ -240,7 +240,7 @@ This architecture makes safety compositional: each skill adds one constraint. Th (let ((next-action (funcall gate current-action context))) (when (and (listp next-action) (member (proto-get next-action :type) '(:LOG :EVENT))) - (harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) + (log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) (return-from cognitive-verify next-action)) (when next-action (setf current-action next-action)))))) current-action)) diff --git a/org/core-loop.org b/org/core-loop.org index 11f350c..2a0ccb7 100644 --- a/org/core-loop.org +++ b/org/core-loop.org @@ -76,11 +76,11 @@ The function handles four failure modes: (let ((depth (getf current-signal :depth 0)) (meta (getf current-signal :meta))) (when (> depth 10) - (harness-log "METABOLISM ERROR: Max recursion depth reached.") + (log-message "METABOLISM ERROR: Max recursion depth reached.") (return nil)) (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (harness-log "METABOLISM: Interrupted by shutdown signal.") + (log-message "METABOLISM: Interrupted by shutdown signal.") (return nil)) (handler-case @@ -95,9 +95,9 @@ The function handles four failure modes: (setf current-signal nil)))) (error (c) (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) + (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) (unless (member sensor '(:loop-error :tool-error :syntax-error)) - (harness-log "CRITICAL ERROR: Initiating Micro-Rollback.") + (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") (rollback-memory 0)) (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) (setf current-signal nil) @@ -236,14 +236,14 @@ Boot sequence: (sb-sys:enable-interrupt sb-unix:sigint (lambda (sig code scp) (declare (ignore sig code scp)) - (harness-log "SHUTDOWN: SIGINT received. Saving memory...") + (log-message "SHUTDOWN: SIGINT received. Saving memory...") (when *shutdown-save-enabled* (save-memory-to-disk)) (uiop:quit 0))) (let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600))) (loop (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (harness-log "SHUTDOWN: Interrupt flag set. Saving memory...") + (log-message "SHUTDOWN: Interrupt flag set. Saving memory...") (when *shutdown-save-enabled* (save-memory-to-disk)) (return)) (sleep sleep-interval)))) diff --git a/org/core-memory.org b/org/core-memory.org index 5f0c6d8..b94e0bd 100644 --- a/org/core-memory.org +++ b/org/core-memory.org @@ -239,7 +239,7 @@ Called automatically before significant memory mutations (buffer updates from Em (push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*) (when (> (length *memory-snapshots*) 20) (setf *memory-snapshots* (subseq *memory-snapshots* 0 20))) - (harness-log "MEMORY - CoW Memory snapshot created."))) + (log-message "MEMORY - CoW Memory snapshot created."))) #+end_src ** Memory Rollback (memory-rollback) @@ -254,8 +254,8 @@ This is the immune system's last resort. When the metabolic loop catches an unha (let ((snapshot (nth index *memory-snapshots*))) (if snapshot (progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data))) - (harness-log "MEMORY - Memory rolled back to snapshot ~a" index)) - (harness-log "MEMORY ERROR - Snapshot ~a not found." index)))) + (log-message "MEMORY - Memory rolled back to snapshot ~a" index)) + (log-message "MEMORY ERROR - Snapshot ~a not found." index)))) #+end_src ** Persistence — Snapshot Path (~*memory-snapshot-path*~) @@ -288,7 +288,7 @@ The serialization uses ~prin1~, which produces human-readable Lisp output. The f (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))) - (harness-log "MEMORY - Saved to ~a" path))) + (log-message "MEMORY - Saved to ~a" path))) #+end_src ** Load from Disk (memory-load) @@ -309,8 +309,8 @@ Restores memory state from a previously saved snapshot file. Called during boot (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))) - (harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*)))))) - (error (c) (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))) + (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) #+end_src diff --git a/org/gateway-manager.org b/org/gateway-manager.org index acf053c..e0526ce 100644 --- a/org/gateway-manager.org +++ b/org/gateway-manager.org @@ -54,12 +54,12 @@ Registration of available gateway implementations: each platform registers its p (text (cdr (assoc :text message)))) (setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id) (when (and text chat-id) - (harness-log "TELEGRAM: Received message from ~a" chat-id) + (log-message "TELEGRAM: Received message from ~a" chat-id) (inject-stimulus (list :type :EVENT :meta (list :source :telegram :chat-id (format nil "~a" chat-id)) :payload (list :sensor :user-input :text text))))))) - (error (c) (harness-log "TELEGRAM POLL ERROR: ~a" c)))))) + (error (c) (log-message "TELEGRAM POLL ERROR: ~a" c)))))) (defun telegram-send (action context) "Sends a message via Telegram." @@ -70,14 +70,14 @@ Registration of available gateway implementations: each platform registers its p (text (or (getf payload :text) (getf action :text))) (token (telegram-get-token))) (when (and token chat-id text) - (harness-log "TELEGRAM: Sending message to ~a..." chat-id) + (log-message "TELEGRAM: Sending message to ~a..." chat-id) (handler-case (let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token))) (dex:post url :headers '(("Content-Type" . "application/json")) :content (cl-json:encode-json-to-string `((chat_id . ,chat-id) (text . ,text))))) - (error (c) (harness-log "TELEGRAM ERROR: ~a" c)))))) + (error (c) (log-message "TELEGRAM ERROR: ~a" c)))))) #+end_src ** Signal Implementation @@ -101,12 +101,12 @@ Registration of available gateway implementations: each platform registers its p (data-message (cdr (assoc :data-message envelope))) (text (cdr (assoc :message data-message)))) (when (and source text) - (harness-log "SIGNAL: Received message from ~a" source) + (log-message "SIGNAL: Received message from ~a" source) (inject-stimulus (list :type :EVENT :meta (list :source :signal :chat-id source) :payload (list :sensor :user-input :text text)))))))) - (error (c) (harness-log "SIGNAL POLL ERROR: ~a" c)))))) + (error (c) (log-message "SIGNAL POLL ERROR: ~a" c)))))) (defun signal-send (action context) "Sends a message via Signal." @@ -117,11 +117,11 @@ Registration of available gateway implementations: each platform registers its p (text (or (getf payload :text) (getf action :text))) (account (signal-get-account))) (when (and account chat-id text) - (harness-log "SIGNAL: Sending message to ~a..." chat-id) + (log-message "SIGNAL: Sending message to ~a..." chat-id) (handler-case (uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id) :output :string :error-output :string) - (error (c) (harness-log "SIGNAL ERROR: ~a" c)))))) + (error (c) (log-message "SIGNAL ERROR: ~a" c)))))) #+end_src ** Gateway Registry Initialization @@ -171,7 +171,7 @@ The main entry point for linking. Validates the registry entry, stores the token platform (loop for k being the hash-keys of *gateway-registry* collect k))) (when (or (null token) (zerop (length token))) (error "Token cannot be empty")) - (harness-log "GATEWAY: Linking to ~a..." platform-lc) + (log-message "GATEWAY: Linking to ~a..." platform-lc) (gateway-unlink platform-lc) (let* ((registry-entry (gethash platform-lc *gateway-registry*)) (interval (or (getf registry-entry :default-interval) 5))) @@ -179,7 +179,7 @@ The main entry point for linking. Validates the registry entry, stores the token (list :token token :interval interval :enabled t)) (vault-set-secret (intern (string-upcase platform-lc) :keyword) token) (gateway-start platform-lc) - (harness-log "GATEWAY: Successfully linked ~a" platform-lc) + (log-message "GATEWAY: Successfully linked ~a" platform-lc) (format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc) t))) #+end_src @@ -192,7 +192,7 @@ Stops the polling thread and removes the config entry. (let ((platform-lc (string-downcase platform))) (gateway-stop platform-lc) (remhash platform-lc *gateway-configs*) - (harness-log "GATEWAY: Unlinked ~a" platform-lc) + (log-message "GATEWAY: Unlinked ~a" platform-lc) (format t "Successfully unlinked ~a gateway.~%" platform-lc) t)) #+end_src @@ -216,7 +216,7 @@ Creates a background thread that calls the platform's poll function on an interv (funcall poll-fn)) (sleep interval))) :name (format nil "passepartout-~a-gateway" platform-lc))) - (harness-log "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval))))))))) + (log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval))))))))) #+end_src *** Stop polling (gateway-stop) @@ -228,7 +228,7 @@ Destroys the polling thread and nulls the thread reference. (let ((config (gethash platform-lc *gateway-configs*))) (when (and config (getf config :thread)) (when (bt:thread-alive-p (getf config :thread)) - (harness-log "GATEWAY: Stopping ~a polling thread" platform-lc) + (log-message "GATEWAY: Stopping ~a polling thread" platform-lc) (bt:destroy-thread (getf config :thread)))) (setf (getf config :thread) nil)))) #+end_src diff --git a/org/programming-lisp.org b/org/programming-lisp.org index 5a69823..5af8c23 100644 --- a/org/programming-lisp.org +++ b/org/programming-lisp.org @@ -104,10 +104,10 @@ The skill has four layers: (if (= code 0) out (progn - (harness-log "FORMAT ERROR: ~a" err) + (log-message "FORMAT ERROR: ~a" err) code-string)))) (error (c) - (harness-log "FORMAT EXCEPTION: ~a" c) + (log-message "FORMAT EXCEPTION: ~a" c) code-string))) #+end_src diff --git a/org/programming-literate.org b/org/programming-literate.org index ff5e260..377f4f9 100644 --- a/org/programming-literate.org +++ b/org/programming-literate.org @@ -38,12 +38,12 @@ The `.lisp` file is derived, not authored. Never edit `.lisp` directly. All chan #+begin_src lisp (defun literate-block-balance-check (org-file) "Verifies that all Lisp source blocks in an Org file are balanced." - (harness-log "LITERATE: Checking block balance for ~a" org-file) + (log-message "LITERATE: Checking block balance for ~a" org-file) t) (defun literate-tangle-sync-check (org-file lisp-file) "Verifies that the Lisp file matches the tangled output of the Org file." - (harness-log "LITERATE: Checking tangle sync for ~a <-> ~a" org-file lisp-file) + (log-message "LITERATE: Checking tangle sync for ~a <-> ~a" org-file lisp-file) t) #+end_src diff --git a/org/programming-org.org b/org/programming-org.org index aa956a7..62805b8 100644 --- a/org/programming-org.org +++ b/org/programming-org.org @@ -76,7 +76,7 @@ Returns the filtered content as a string." (filetags (org-filetags-extract raw))) (if (org-privacy-tag-p filetags) (progn - (harness-log "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) + (log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) nil) (org-privacy-strip raw)))) #+end_src @@ -184,7 +184,7 @@ Returns the filtered content as a string." (defun org-modify (filepath id changes) "Placeholder for Emacs-driven modification of a specific node." (declare (ignore changes)) - (harness-log "UTILS-ORG: Applying changes to ~a in ~a" id filepath) + (log-message "UTILS-ORG: Applying changes to ~a in ~a" id filepath) t) #+end_src diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index 61e9b3a..8c16c8e 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -291,12 +291,12 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 0: REPL verification lint (warn, don't block) (repl-lint - (harness-log "BOUNCER: ~a" (proto-get repl-lint :text)) + (log-message "BOUNCER: ~a" (proto-get repl-lint :text)) action) ;; Vector 1: Lisp syntax validation (block bad lisp writes) ((and lisp-valid (eq (getf lisp-valid :status) :error)) - (harness-log "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) + (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) (list :type :LOG :payload (list :level :error :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) @@ -304,7 +304,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 2: File read to a protected secret path ((and filepath (dispatcher-check-secret-path filepath)) (let ((matched (dispatcher-check-secret-path filepath))) - (harness-log "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) + (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) (list :type :LOG :payload (list :level :error :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) @@ -312,7 +312,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 3: Content contains secret patterns ((and text (dispatcher-exposure-scan text)) (let ((matched (dispatcher-exposure-scan text))) - (harness-log "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) + (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) (list :type :LOG :payload (list :level :error :text "Action blocked: Content contains potential secret exposure.")))) @@ -320,21 +320,21 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 4: Content contains vault secrets ((and text (dispatcher-vault-scan text)) (let ((secret-name (dispatcher-vault-scan text))) - (harness-log "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) + (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) (list :type :LOG :payload (list :level :error :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) ;; Vector 5: Privacy-tagged content in action ((and tags (dispatcher-check-privacy-tags tags)) - (harness-log "PRIVACY VIOLATION: Action contains privacy-tagged content") + (log-message "PRIVACY VIOLATION: Action contains privacy-tagged content") (list :type :LOG :payload (list :level :warn :text "Action blocked: Content tagged with privacy filter."))) ;; Vector 6: Text leaks privacy tag names ((and text (dispatcher-check-text-for-privacy text)) - (harness-log "PRIVACY WARNING: Text may contain leaked private content") + (log-message "PRIVACY WARNING: Text may contain leaked private content") (list :type :LOG :payload (list :level :warn :text "Action blocked: Text may reference private content."))) @@ -342,7 +342,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ;; Vector 7: Shell destructive/injection patterns ((and cmd (dispatcher-check-shell-safety cmd)) (let ((matched (dispatcher-check-shell-safety cmd))) - (harness-log "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) + (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) (list :type :LOG :payload (list :level :error :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) @@ -351,14 +351,14 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." ((and (or (eq target :shell) (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (dispatcher-check-network-exfil cmd)) - (harness-log "SECURITY WARNING: External network call detected. Queuing for approval.") + (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") (list :type :EVENT :payload (list :sensor :approval-required :action action))) ;; Vector 8: High-impact action approval ((or (member target '(:shell)) (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (and (eq target :emacs) (eq (proto-get payload :action) :eval))) - (harness-log "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) + (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) (list :type :EVENT :payload (list :sensor :approval-required :action action))) (t action)))) @@ -375,7 +375,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (tags (getf attrs :TAGS)) (action-str (getf attrs :ACTION))) (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) - (harness-log "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node)) + (log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node)) (let ((action (ignore-errors (read-from-string action-str)))) (when action (setf (getf action :approved) t) @@ -390,7 +390,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (defun dispatcher-flight-plan-create (blocked-action) "Creates a Flight Plan node for manual approval." (let ((id (org-id-new))) - (harness-log "BOUNCER: Creating flight plan node '~a'..." id) + (log-message "BOUNCER: Creating flight plan node '~a'..." id) (list :type :REQUEST :target :emacs :payload (list :action :insert-node :id id :attributes (list :TITLE "Flight Plan: High-Risk Action" diff --git a/org/security-policy.org b/org/security-policy.org index bb11772..fa0155b 100644 --- a/org/security-policy.org +++ b/org/security-policy.org @@ -23,7 +23,7 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha (if (and explanation (stringp explanation) (> (length explanation) 10)) action (progn - (harness-log "POLICY VIOLATION: Action lacks sufficient explanation.") + (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") (list :type :LOG :payload (list :level :warn :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) diff --git a/org/system-actuator-shell.org b/org/system-actuator-shell.org index 39e9fdf..d2b04cd 100644 --- a/org/system-actuator-shell.org +++ b/org/system-actuator-shell.org @@ -28,7 +28,7 @@ Because shell execution is the highest-risk operation in the system, the Shell A (max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout)) (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) (wrapped-cmd (format nil "timeout ~a bash -c ~s" timeout cmd))) - (harness-log "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) + (log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) (multiple-value-bind (out err code) (uiop:run-program (list "bash" "-c" wrapped-cmd) :output :string :error-output :string diff --git a/org/system-archivist.org b/org/system-archivist.org index 1514266..0823bcc 100644 --- a/org/system-archivist.org +++ b/org/system-archivist.org @@ -14,7 +14,7 @@ The *Scribe Skill* manages the agent's internal documentation and logs. "Logs a metabolic signal for later analysis." (let ((type (getf signal :type)) (payload (getf signal :payload))) - (harness-log "SCRIBE: [~a] ~s" type payload))) + (log-message "SCRIBE: [~a] ~s" type payload))) #+end_src ** Skill Registration diff --git a/org/system-event-orchestrator.org b/org/system-event-orchestrator.org new file mode 100644 index 0000000..365dc68 --- /dev/null +++ b/org/system-event-orchestrator.org @@ -0,0 +1,240 @@ +#+TITLE: SKILL: Event Orchestrator (system-event-orchestrator.org) +#+AUTHOR: Agent +#+FILETAGS: :system:orchestrator:hooks:cron: +#+PROPERTY: header-args:lisp :tangle ../lisp/system-event-orchestrator.lisp + +* Architectural Intent + +The Event Orchestrator unifies three control-plane mechanisms that were previously scattered across the system: + +1. **Hooks** — actions triggered when Org nodes with specific ~#+HOOK:~ properties are modified +2. **Cron** — time-based scheduled jobs using Org-mode timestamp repeat expressions +3. **Routing** — three-tier complexity classifier that decides whether a job needs the LLM at all + +Before the Orchestrator, each of these was handled ad-hoc. The heartbeat thread injected raw ~:heartbeat~ signals that skills had to parse themselves. Memory auto-save was a hardcoded counter in ~core-loop~. There was no way to say "when this file changes, verify its integrity" or "archive old tasks every Sunday." + +The Orchestrator attaches to the heartbeat as a deterministic gate (same pattern as the Dispatcher, the Archivist, and every other heartbeat-driven skill). On each tick, it checks the cron registry for due jobs and dispatches them at the appropriate tier. + +** The three tiers: + +| Tier | LLM? | Mechanism | Example | +|------|------|-----------|---------| +| ~:reflex~ | No | Direct function call | "Run integrity check" | +| ~:cognition~ | Light | Injected as user-input | "Summarize today's notes" | +| ~:reasoning~ | Full | Injected as user-input | "Plan the project architecture" | + +The default classifier uses keywords in the context to determine the tier: ~rm~, ~write-file~, ~shell~ → ~:reflex~; ~summarize~, ~list~, ~find~ → ~:cognition~; everything else → ~:reasoning~. This can be overridden by setting ~*tier-classifier*~ to a custom function. + +* Implementation + +** Package definition + +#+begin_src lisp +(defpackage :passepartout.system-event-orchestrator + (:use :cl :passepartout) + (:export + :orchestrator-register-hook + :orchestrator-register-cron + :orchestrator-classify + :orchestrator-on-heartbeat + :orchestrator-bootstrap + :orchestrator-dispatch + :default-classifier + :parse-org-repeat + :*hook-registry* + :*cron-registry* + :*tier-classifier*)) + +(in-package :passepartout.system-event-orchestrator) +#+end_src + +** Registries + +The hook registry maps Org-mode property names (like ~verify-integrity~ from a ~#+HOOK: verify-integrity~ headline property) to lists of gate function symbols. When a node with that hook is modified, the orchestrator calls each gate in sequence. + +The cron registry maps job names (keywords like ~:weekly-report~) to configuration plists. Each entry contains the repeat expression, the action function, and the dispatch tier. + +#+begin_src lisp +(defvar *hook-registry* (make-hash-table :test 'equal) + "Maps hook property string → list of gate function symbols.") + +(defvar *cron-registry* (make-hash-table :test 'equal) + "Maps job name string → plist (:next-run :expression :repeat :action :tier).") + +(defvar *tier-classifier* nil + "Optional function (context) → :reflex | :cognition | :reasoning.") +#+end_src + +** Default tier classifier + +Uses keyword matching on the context text to determine which tier to dispatch at. The matching is deliberately coarse — it's a heuristic, not an exact science. Users who need precise control can set ~*tier-classifier*~ to their own function. + +#+begin_src lisp +(defun default-classifier (context) + "Rule-based tier classification. +:reflex — file/shell operations, deterministic checks +:cognition — text processing, summarization, simple Q&A +:reasoning — planning, analysis, multi-step decisions" + (let* ((text (or (getf context :text) "")) + (lower (string-downcase text))) + (cond + ((or (search "rm " lower) + (search "write-file" lower) + (search "shell" lower) + (search "verify-" lower)) + :reflex) + ((or (search "summarize" lower) + (search "list" lower) + (search "find " lower) + (search "what is" lower) + (search "search" lower)) + :cognition) + (t :reasoning)))) +#+end_src + +** Parsing Org-mode repeat timestamps + +Org-mode timestamps use the format ~+<2026-05-02 Sat +1w>~ for repeating events. The ~+1w~ means "repeat every week," ~+1d~ means "every day," etc. This function extracts the repeat unit and value. + +Returns ~(UNIT VALUE)~ like ~(:W 1)~ for weekly, or ~NIL~ if there's no repeat clause. + +#+begin_src lisp +(defun parse-org-repeat (timestamp-string) + (let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string)) + (parts (uiop:split-string cleaned :separator '(#\space))) + (repeat-part (ignore-errors (car (last parts))))) + (when (and repeat-part (uiop:string-prefix-p "+" repeat-part)) + (let* ((rest (subseq repeat-part 1)) + (num-end (position-if (lambda (c) (not (digit-char-p c))) rest)) + (num (parse-integer (subseq rest 0 num-end))) + (unit-str (subseq rest num-end))) + (list (intern (string-upcase unit-str) :keyword) num))))) +#+end_src + +** Registering a hook + +Called at boot or when a new ~#+HOOK:~ property is discovered. Appends the gate function to the registry entry for that hook. + +#+begin_src lisp +(defun orchestrator-register-hook (hook-property gate-function) + "Registers a deterministic gate to fire when an Org node with +the #+HOOK: property matching HOOK-PROPERTY is modified." + (push gate-function + (gethash (string-downcase (string hook-property)) *hook-registry*)) + (log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function)) +#+end_src + +** Registering a cron job + +Each cron job has a name, an Org-mode timestamp with optional repeat, an action function, and a dispatch tier. The ~:next-run~ field is initialized to the current time so the job fires on the first heartbeat cycle (it will be rescheduled according to the repeat pattern after execution). + +#+begin_src lisp +(defun orchestrator-register-cron (name expression action-function tier) + "Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode +timestamp string with optional repeat. TIER is :reflex :cognition :reasoning." + (let* ((repeat (parse-org-repeat expression)) + (now (get-universal-time))) + (setf (gethash (string-downcase (string name)) *cron-registry*) + (list :next-run now + :expression expression + :repeat repeat + :action action-function + :tier tier)) + (log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)" + name tier repeat))) +#+end_src + +** Dispatch + +Routes an action to the appropriate executor based on its tier. Reflex actions are called directly (deterministic, no LLM overhead). Cognition and reasoning actions are injected as user-input events, which triggers the normal Perceive → Reason → Act pipeline (but at different model tiers). + +#+begin_src lisp +(defun orchestrator-dispatch (action tier) + "Execute ACTION at the specified TIER." + (flet ((safe-inject (text) + (when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout)) + (funcall (find-symbol "STIMULUS-INJECT" :passepartout) + (list :type :EVENT + :payload (list :sensor :user-input :text text)))))) + (ecase tier + (:reflex + (if (functionp action) + (funcall action) + (when (and (symbolp action) (fboundp action)) + (funcall action))) + :dispatched) + (:cognition + (safe-inject (format nil "~a" action)) + :injected) + (:reasoning + (safe-inject (format nil "~a" action)) + :injected)))) +#+end_src + +** Heartbeat handler + +Called on each heartbeat cycle. Checks the cron registry for jobs whose ~:next-run~ time has passed, dispatches them, and reschedules repeating jobs. + +The rescheduling computes the next run based on the repeat unit: ~:d~ (days), ~:w~ (weeks), ~:m~ (months), defaulting to ~:h~ (hours). This is deliberately simple — full calendar-aware scheduling (skip weekends, respect business hours) can be added later. + +Returns ~nil~ so it doesn't block the heartbeat signal from reaching other skills. + +#+begin_src lisp +(defun orchestrator-on-heartbeat (context) + "Called on each heartbeat tick. Checks and dispatches due cron jobs." + (declare (ignore context)) + (let ((now (get-universal-time)) + (due-jobs nil)) + (maphash (lambda (name config) + (let ((next-run (getf config :next-run))) + (when (>= now next-run) + (push (cons name config) due-jobs)))) + *cron-registry*) + (dolist (job due-jobs) + (let* ((name (car job)) + (config (cdr job)) + (action (getf config :action)) + (tier (getf config :tier)) + (repeat (getf config :repeat)) + (result (orchestrator-dispatch action tier))) + (log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a" + name tier result) + (when repeat + (let* ((unit (first repeat)) + (value (second repeat)) + (interval (case unit + (:d (* 86400 value)) + (:w (* 604800 value)) + (:m (* 2592000 value)) + (t (* 3600 value))))) + (setf (getf (gethash name *cron-registry*) :next-run) + (+ now interval)))))) + nil)) +#+end_src + +** Bootstrap + +Scans all Org files for ~#+HOOK:~ properties and auto-registers them. Currently a placeholder — full implementation requires the Org-mode AST parser, which is available in the ~programming-org~ skill but its output format needs to be wired into the orchestrator. + +Manual registration (via ~orchestrator-register-hook~) works today. + +#+begin_src lisp +(defun orchestrator-bootstrap () + "Scans all Org files for #+HOOK: properties and registers them." + (log-message "ORCHESTRATOR: Bootstrap complete")) +#+end_src + +** Skill registration + +The orchestrator registers as a skill with low priority so it runs after critical skills (policy, dispatcher) but before the heartbeat processing. The trigger matches ~:heartbeat~ sensor events. + +#+begin_src lisp +(defskill :passepartout-system-event-orchestrator + :priority 80 + :trigger (lambda (ctx) + (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action context) + (declare (ignore action)) + (orchestrator-on-heartbeat context) + nil)) +#+end_src diff --git a/org/system-memory.org b/org/system-memory.org index 3b35acc..e714cef 100644 --- a/org/system-memory.org +++ b/org/system-memory.org @@ -12,7 +12,7 @@ Because Lisp is homoiconic (code is data), memory objects can be read as executa #+begin_src lisp (defun memory-inspect () "Allows the system to inspect its own memory state." - (harness-log "MEMORY: Self-inspection triggered.")) + (log-message "MEMORY: Self-inspection triggered.")) #+end_src ** Skill Registration diff --git a/org/system-self-improve.org b/org/system-self-improve.org index d498abc..5a52e33 100644 --- a/org/system-self-improve.org +++ b/org/system-self-improve.org @@ -16,7 +16,7 @@ The function intentionally only logs the change — the actual file I/O is handl (defun self-improve-edit (filepath old-text new-text) "Applies a transformation to a source file." (declare (ignore old-text new-text)) - (harness-log "SELF-EDIT: Applying changes to ~a" filepath)) + (log-message "SELF-EDIT: Applying changes to ~a" filepath)) #+end_src ** Skill Registration @@ -39,7 +39,7 @@ When a skill file fails to compile or a runtime error occurs, Self Fix attempts (defun self-improve-fix (skill-name error-log) "Attempts to diagnose and repair a broken skill." (declare (ignore error-log)) - (harness-log "SELF-FIX: Attempting repair of ~a..." skill-name)) + (log-message "SELF-FIX: Attempting repair of ~a..." skill-name)) #+end_src ** Skill Registration