diff --git a/src/task/shell-logs.lisp b/src/task/shell-logs.lisp index 56c9fe0f..dec67fa3 100644 --- a/src/task/shell-logs.lisp +++ b/src/task/shell-logs.lisp @@ -64,7 +64,7 @@ (defun shell-log--capture-file-p (value) "Accept only the executor's plain basename, never a path or manifest name." (and (stringp value) (<= 1 (length value) 240) - (not (member value '("." ".." "manifest.sexp") :test #'string=)) + (not (member value '("." ".." "manifest.sexp" "owner.lock") :test #'string=)) (every (lambda (character) (or (find character "-." :test #'char=) (find character "_0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -94,11 +94,46 @@ "Return the private portable manifest in DIRECTORY." (merge-pathnames "manifest.sexp" directory)) +(defmacro with-shell-log-lock ((configuration) &body body) + "Serialize lifecycle changes in this image and across processes sharing storage." + (let ((path (gensym "PATH")) + (settings (gensym "CONFIGURATION"))) + `(let* ((,settings ,configuration) + (,path (merge-pathnames "tasks/shell-log.lock" (config :data-root ,settings)))) + (with-lock-held (*shell-log-lock*) + (shell-log--safe-path ,settings ,path) + (ensure-directories-exist ,path) + (call-with-file-lock ,path + (lambda () + (platform-make-private *platform* ,path) + ,@body)))))) + +(-> shell-log--release-owner (pathname) null) +(defun shell-log--release-owner (capture-directory) + "Release the process lease and remove its local thread pin." + (let ((entry (gethash (namestring capture-directory) *shell-log-active*))) + (when (consp entry) (lease-release (rest entry))) + (remhash (namestring capture-directory) *shell-log-active*)) + nil) + (-> shell-log--active-p (pathname) boolean) (defun shell-log--active-p (directory) - "Test the live owning thread, not a pin restored from a stopped image." - (let ((thread (gethash (namestring directory) *shell-log-active*))) - (and thread (thread-alive-p thread) t))) + "Test a live local thread or a foreign process lease, never a stale heap pin." + (let ((entry (gethash (namestring directory) *shell-log-active*)) + (path (merge-pathnames "owner.lock" directory))) + (when entry + (if (and (consp entry) (thread-alive-p (first entry)) (lease-held-p (rest entry))) + (return-from shell-log--active-p t) + (shell-log--release-owner directory))) + (let ((status (platform-path-status *platform* path :follow-links-p nil))) + (when status + (unless (eq (platform-file-status-kind status) ':file) + (shell-log--fail "Unsafe shell log owner lock." path)) + (handler-case + (let ((lease (lease-acquire path))) + (lease-release lease) + nil) + (file-lock-busy () t)))))) (-> shell-log--measure-captures (configuration pathname list) integer) (defun shell-log--measure-captures (configuration directory metadata) @@ -282,12 +317,42 @@ Disable measurement until resource resolution has checked ancestor ownership." nil))) t)) +(-> shell-log--manifest-staging-p (pathname) boolean) +(defun shell-log--manifest-staging-p (file) + "Recognize the private staging names used by sexp-store snapshot publication." + (let ((name (pathname-name file))) + (and (equal "staging" (pathname-type file)) + (stringp name) (<= 13 (length name) 24) + (uiop:string-prefix-p ".sexp-store-" name) + (every (lambda (character) (find character "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + (subseq name 12)) + t))) + +(-> shell-log--scan-manifest (configuration pathname) list) +(defun shell-log--scan-manifest (configuration capture-directory) + "Read a manifest, reclaiming interrupted unpublished allocations under the lock." + (if (probe-file (shell-log--safe-path configuration (shell-log--manifest-path capture-directory))) + (shell-log--read-manifest configuration capture-directory) + (progn + (unless (shell-log--active-p capture-directory) + (unless (and (null (uiop:subdirectories capture-directory)) + (every (lambda (file) + (and (or (string= "owner.lock" (file-namestring file)) + (shell-log--manifest-staging-p file)) + (shell-log--safe-path configuration file) + (eq ':file (platform-file-status-kind + (platform-path-status *platform* file :follow-links-p nil))))) + (uiop:directory-files capture-directory))) + (shell-log--fail "Unpublished shell log contains unexpected files." capture-directory)) + (platform-delete-directory-tree *platform* capture-directory :validate t)) + nil))) + (-> shell-log--trim-tombstones (configuration) null) (defun shell-log--trim-tombstones (configuration) "Bound tombstone metadata separately, deleting only already-pruned artifacts." (let* ((entries (loop for directory in (shell-log--directories configuration) - for metadata = (shell-log--read-manifest configuration directory) + for metadata = (shell-log--scan-manifest configuration directory) when (eq (getf metadata :state) ':pruned) collect (list directory metadata))) (count (length entries))) @@ -298,8 +363,11 @@ Disable measurement until resource resolution has checked ancestor ownership." *shell-log-tombstone-age*)) (unless (and (null (uiop:subdirectories directory)) (every (lambda (file) - (and (string= "manifest.sexp" (file-namestring file)) - (shell-log--safe-path configuration file))) + (and (or (member (file-namestring file) '("manifest.sexp" "owner.lock") :test #'string=) + (shell-log--manifest-staging-p file)) + (shell-log--safe-path configuration file) + (eq ':file (platform-file-status-kind + (platform-path-status *platform* file :follow-links-p nil))))) (uiop:directory-files directory))) (shell-log--fail "Pruned shell log directory contains unexpected files." directory)) (platform-delete-directory-tree *platform* directory :validate t) @@ -312,8 +380,8 @@ Disable measurement until resource resolution has checked ancestor ownership." Keep manifests as tombstones so old references have truthful diagnostics." (let* ((entries (loop for directory in (shell-log--directories configuration) - for metadata = (shell-log--read-manifest configuration directory) - unless (eq (getf metadata :state) ':pruned) + for metadata = (shell-log--scan-manifest configuration directory) + when (and metadata (not (eq (getf metadata :state) ':pruned))) collect (list directory metadata (getf metadata :accounted-bytes 0)))) (total (loop for entry in entries sum (third entry))) (count (length entries))) @@ -346,7 +414,7 @@ Keep manifests as tombstones so old references have truthful diagnostics." (-> shell-log-allocate (tool-context &key (:job t) (:merge-output-p boolean)) shell-log-artifact) (defun shell-log-allocate (context &key job (merge-output-p t)) "Allocate private execution-owned storage and persist ownership BEFORE launch." - (with-lock-held (*shell-log-lock*) + (with-shell-log-lock ((tool-context-configuration context)) (let* ((configuration (tool-context-configuration context)) (agent (tool-context-agent context)) (parent-job (and (typep agent 'task-child-agent) (task-child-agent-job agent))) @@ -359,7 +427,8 @@ Keep manifests as tombstones so old references have truthful diagnostics." (directory (merge-pathnames (format nil "~A/shell-log/~A/" execution identifier) (task--artifact-group-root configuration root))) (allocation-started-p nil) - (published-p nil)) + (published-p nil) + (lease nil)) (unless (every #'shell-log--component-p (list root execution identifier)) (shell-log--fail "Invalid private shell log execution identity.")) (unwind-protect @@ -395,8 +464,10 @@ Keep manifests as tombstones so old references have truthful diagnostics." :merge-output-p merge-output-p :capture-byte-limit *shell-log-capture-byte-limit* :reserved-bytes reservation)))) + (setf lease (lease-acquire (merge-pathnames "owner.lock" directory))) + (platform-make-private *platform* (merge-pathnames "owner.lock" directory)) (shell-log--write-manifest artifact) - (setf (gethash (namestring directory) *shell-log-active*) (current-thread) + (setf (gethash (namestring directory) *shell-log-active*) (cons (current-thread) lease) published-p t) artifact)) (shell-log-error (condition) @@ -405,6 +476,7 @@ Keep manifests as tombstones so old references have truthful diagnostics." (shell-log--fail (format nil "Could not allocate private shell capture: ~A" condition) directory))) (unless published-p + (when lease (lease-release lease)) (remhash (namestring directory) *shell-log-active*) (when allocation-started-p (sb-sys:without-interrupts @@ -434,7 +506,7 @@ Keep manifests as tombstones so old references have truthful diagnostics." (defun shell-log-record-capture (artifact result &key (closed-p t)) "Persist allocated filenames before launch or closed evidence on every unwind. With CLOSED-P false, retain the active reservation and prevent pruning." - (with-lock-held (*shell-log-lock*) + (with-shell-log-lock ((shell-log-artifact-configuration artifact)) (unwind-protect (let ((metadata (copy-tree (shell-log-artifact-metadata artifact)))) (setf (getf metadata :state) (if closed-p ':closed ':active) @@ -455,14 +527,14 @@ With CLOSED-P false, retain the active reservation and prevent pruning." (shell-log--write-manifest artifact) (copy-tree metadata)) (when closed-p - (remhash (namestring (shell-log-capture-directory artifact)) *shell-log-active*))))) + (shell-log--release-owner (shell-log-capture-directory artifact)))))) (-> shell-log-release-artifact (shell-log-artifact) null) (defun shell-log-release-artifact (artifact) "Idempotently close an abandoned allocation without fabricating capture data. Always release the active pin, including when manifest publication fails. Callers handling another condition may ignore this logging failure to preserve that cause." - (with-lock-held (*shell-log-lock*) + (with-shell-log-lock ((shell-log-artifact-configuration artifact)) (let ((directory (shell-log-capture-directory artifact))) (when (or (gethash (namestring directory) *shell-log-active*) (eq (getf (shell-log-artifact-metadata artifact) :state) ':active)) @@ -481,7 +553,7 @@ handling another condition may ignore this logging failure to preserve that caus (getf metadata :captures))) (setf (shell-log-artifact-metadata artifact) metadata) (shell-log--write-manifest artifact)) - (remhash (namestring directory) *shell-log-active*))))) + (shell-log--release-owner directory))))) nil) (-> shell-log--public-metadata (list) list) diff --git a/tests/shell-log-resource-tests.lisp b/tests/shell-log-resource-tests.lisp index c91bbc92..2055bb9c 100644 --- a/tests/shell-log-resource-tests.lisp +++ b/tests/shell-log-resource-tests.lisp @@ -432,10 +432,7 @@ (test-assert (tool-result-success-p (shell-log-tests--read (shell-log-tests--resolve artifact context) context (json-object))) "Tombstones produce a diagnostic, not a failed session") - (remhash (namestring (shell-log-capture-directory replacement)) *shell-log-active*) - (test-assert (eq ':interrupted (getf (shell-log--read-manifest - configuration (shell-log-capture-directory replacement)) :state)) - "Abandoned prelaunch manifests never claim completion")))) + (shell-log-release-artifact replacement)))) (with-test-configuration (configuration) (let* ((*shell-log-active* (make-hash-table :test #'equal)) (*shell-log-capture-byte-limit* 32) @@ -478,3 +475,272 @@ (not (getf record :complete-p)) (getf record :truncated-p)) "Portable manifests preserve storage loss separately from execution failure")))))) nil) + +(-> test-shell-log-cross-process-lifecycle () null) +(defun test-shell-log-cross-process-lifecycle () + "Keep live foreign captures readable and reserved, then reclaim after owner exit." + (with-test-configuration (configuration root) + (let* ((*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1) + (context (shell-log-tests--context configuration "shell-process")) + (ready (merge-pathnames "capture.sexp" root)) + (worker nil) + (replacement nil)) + (unwind-protect + (progn + (multiple-value-bind (rendered child) + (test-conversation--worker-eval + configuration + (format nil + "(let* ((configuration ~A) + (*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1) + (context (make-instance 'tool-context :configuration configuration :worker nil + :conversation (conversation-create configuration :identifier \"shell-process\"))) + (artifact (shell-log-allocate context)) + (path (merge-pathnames \"output.bin\" (shell-log-capture-directory artifact))) + (capture (make-instance 'cl-exec-sandbox:sandbox-capture :path path))) + (with-open-file (output path :direction ':output :element-type '(unsigned-byte 8)) + (write-sequence (utf8-string-to-octets \"live bytes\") output)) + (shell-log-record-capture artifact + (make-instance 'cl-exec-sandbox:sandbox-result :output-capture capture + :exit-code nil :timed-out-p nil :cancelled-p nil :status ':running) + :closed-p nil) + (task-continuity--write ~S + (list :reference (shell-log-reference artifact) :directory (namestring (shell-log-capture-directory artifact)))))" + (test-conversation--child-configuration-form configuration) ready)) + (declare (ignore rendered)) + (setf worker child)) + (let* ((published (task-continuity--read ready)) + (reference (getf published :reference)) + (capture-directory (getf published :directory))) + (flet ((resolve () + (resource-resolver-resolve (make-instance 'shell-log-resolver :scheme "shell-log") + (subseq reference 10) context))) + (let ((resource (resolve))) + (test-assert (eq ':active (getf (shell-log-resource-metadata resource) :state)) + "Another process's live capture is not interrupted") + (test-assert + (search "live bytes" (tool-result-content + (shell-log-tests--read resource context (json-object)))) + "A live foreign capture can be read through its authorized reference")) + (test-assert (handler-case + (let ((unexpected (shell-log-allocate context))) + (shell-log-release-artifact unexpected) + nil) + (shell-log-error () t)) + "A foreign owner's reservation prevents quota overcommit and pruning") + (test-assert (probe-file (merge-pathnames "output.bin" capture-directory)) + "Quota pressure preserves the live capture file") + (lisp-worker-stop worker) + (setf worker nil) + (test-assert (eq ':interrupted (getf (shell-log-resource-metadata (resolve)) :state)) + "Owner exit releases the kernel lease and exposes interruption") + (setf replacement (shell-log-allocate context)) + (test-assert (eq ':pruned (getf (shell-log-resource-metadata (resolve)) :state)) + "Quota pressure reclaims the dead owner's capture with a truthful tombstone") + (shell-log-release-artifact replacement) + (setf replacement nil) + (let ((*shell-log-tombstone-count-limit* 0)) + (setf replacement (shell-log-allocate context))) + (test-assert (not (probe-file capture-directory)) + "Tombstone expiry removes lease files along with expired metadata"))) + (shell-log-release-artifact replacement) + (setf replacement nil) + (multiple-value-bind (rendered child) + (test-conversation--worker-eval + configuration + (format nil + "(let* ((configuration ~A) + (*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1) + (context (make-instance 'tool-context :configuration configuration :worker nil + :conversation (conversation-create configuration :identifier \"shell-orphan\"))) + (artifact (shell-log-allocate context))) + (platform-delete-file *platform* (shell-log--manifest-path (shell-log-capture-directory artifact))) + (task-continuity--write ~S (list :directory (namestring (shell-log-capture-directory artifact)))))" + (test-conversation--child-configuration-form configuration) ready)) + (declare (ignore rendered)) + (setf worker child)) + (let ((capture-directory (getf (task-continuity--read ready) :directory))) + (lisp-worker-stop worker) + (setf worker nil + replacement (shell-log-allocate context)) + (test-assert (not (probe-file capture-directory)) + "A dead unpublished allocation does not block future shell commands"))) + (when worker (lisp-worker-stop worker)) + (when replacement (shell-log-release-artifact replacement))))) + (with-test-configuration (configuration) + (let* ((context (shell-log-tests--context configuration "shell-staging")) + (directory (merge-pathnames "tasks/shell-staging/interrupted/shell-log/unpublished/" + (config :data-root configuration)))) + (ensure-directories-exist directory) + (dolist (name '("owner.lock" ".sexp-store-A1.staging")) + (with-open-file (stream (merge-pathnames name directory) :direction :output) + (write-string "interrupted publication" stream))) + (let ((artifact (shell-log-allocate context))) + (unwind-protect + (test-assert (not (probe-file directory)) + "Interrupted manifest staging is reclaimed before the next allocation") + (shell-log-release-artifact artifact))))) + (with-test-configuration (configuration) + (let* ((*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1) + (*shell-log-tombstone-count-limit* 0) + (context (shell-log-tests--context configuration "shell-update-staging")) + (original (shell-log-allocate context)) + (directory (shell-log-capture-directory original))) + (shell-log-tests--finish original (utf8-string-to-octets "published")) + (with-open-file (stream (merge-pathnames ".sexp-store-A1.staging" directory) :direction ':output) + (write-string "interrupted later update" stream)) + (let ((replacement (shell-log-allocate context))) + (unwind-protect + (test-assert (not (probe-file directory)) + "A published manifest's abandoned staging does not block tombstone expiry") + (shell-log-release-artifact replacement))))) + (with-test-configuration (configuration root) + (let* ((*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1) + (*shell-log-tombstone-count-limit* 0) + (context (shell-log-tests--context configuration "shell-staging-refusal")) + (original (shell-log-allocate context)) + (directory (shell-log-capture-directory original)) + (staging (merge-pathnames ".sexp-store-A1.staging" directory))) + (shell-log-tests--finish original (utf8-string-to-octets "published")) + (dolist (name '("foreign.bin" ".sexp-store-a1.staging" ".sexp-store-A1.staging.extra")) + (let ((path (merge-pathnames name directory))) + (with-open-file (stream path :direction ':output) + (write-string "unexpected file" stream)) + (test-assert + (handler-case + (let ((artifact (shell-log-allocate context))) + (shell-log-release-artifact artifact) + nil) + (shell-log-error () t)) + "Tombstone expiry refuses unexpected names instead of deleting them") + (test-assert (probe-file path) "Refused files are preserved") + (platform-delete-file *platform* path))) + (with-test-fixture (':symbolic-links "shell manifest staging substitution") + (let ((target (merge-pathnames "staging-target.bin" root))) + (with-open-file (stream target :direction ':output) + (write-string "foreign contents" stream)) + (test-fixture-make-symbolic-link *platform* (namestring target) (namestring staging)) + (test-assert + (handler-case + (let ((artifact (shell-log-allocate context))) + (shell-log-release-artifact artifact) + nil) + (shell-log-error () t)) + "A staging-shaped symbolic link cannot authorize tombstone deletion") + (test-assert (and (probe-file target) + (platform-path-status *platform* staging :follow-links-p nil)) + "Refused staging links and their targets are preserved") + (platform-delete-file *platform* staging))))) + nil) + +(-> test-shell-log-concurrent-allocation () null) +(defun test-shell-log-concurrent-allocation () + "Pause one process after its quota scan and contend from another process." + (with-test-configuration (configuration) + (let ((first-worker nil) + (second-worker nil)) + (flet ((evaluate (worker form) + (let ((response (lisp-worker-request worker ':eval (list :forms (list form))))) + (test-assert (eq (getf (rest response) :status) ':ok) + (format nil "Contention worker completed: ~S" response))))) + (unwind-protect + (progn + (multiple-value-bind (rendered worker) + (test-conversation--worker-eval + configuration + (format nil + "(let* ((configuration ~A) + (scanned (sb-thread:make-semaphore)) + (resume (sb-thread:make-semaphore)) + (done (sb-thread:make-semaphore)) + (hold (sb-thread:make-semaphore)) + (state (list :resume resume :done done :hold hold :result nil)) + (prune (symbol-function 'shell-log--prune))) + (defparameter *shell-log-contention-fixture* state) + (setf (symbol-function 'shell-log--prune) + (lambda (configuration &key (reservation 0)) + (funcall prune configuration :reservation reservation) + (sb-thread:signal-semaphore scanned) + (unless (sb-thread:wait-on-semaphore resume :timeout 30) + (error \"Allocation was never resumed\")))) + (sb-thread:make-thread + (lambda () + (let ((*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1)) + (unwind-protect + (handler-case + (setf (getf state :result) + (shell-log-allocate + (make-instance 'tool-context :configuration configuration :worker nil + :conversation (conversation-create configuration :identifier \"shell-race-first\")))) + (error (condition) (setf (getf state :result) condition))) + (setf (symbol-function 'shell-log--prune) prune) + (sb-thread:signal-semaphore done)) + (sb-thread:wait-on-semaphore hold :timeout 30)))) + (unless (sb-thread:wait-on-semaphore scanned :timeout 30) + (error \"First allocation never completed its scan\")))" + (test-conversation--child-configuration-form configuration))) + (declare (ignore rendered)) + (setf first-worker worker)) + (multiple-value-bind (rendered worker) + (test-conversation--worker-eval + configuration + (format nil + "(let* ((configuration ~A) + (entered (sb-thread:make-semaphore)) + (done (sb-thread:make-semaphore)) + (state (list :done done :result nil))) + (defparameter *shell-log-contention-fixture* state) + (handler-case + (let ((lease (lease-acquire (merge-pathnames \"tasks/shell-log.lock\" (config :data-root configuration))))) + (lease-release lease) + (error \"Quota scan did not hold the cross-process allocation lock\")) + (file-lock-busy () t)) + (sb-thread:make-thread + (lambda () + (let ((*shell-log-capture-byte-limit* 32) + (*shell-log-retention-byte-limit* 32) + (*shell-log-retention-count-limit* 1)) + (sb-thread:signal-semaphore entered) + (unwind-protect + (setf (getf state :result) + (handler-case + (shell-log-allocate + (make-instance 'tool-context :configuration configuration :worker nil + :conversation (conversation-create configuration :identifier \"shell-race-second\"))) + (shell-log-error () :quota-refused))) + (sb-thread:signal-semaphore done))))) + (unless (sb-thread:wait-on-semaphore entered :timeout 30) + (error \"Second allocator never started\")) + (when (sb-thread:wait-on-semaphore done :timeout 0.1) + (error \"Second allocation bypassed the paused quota scan\")))" + (test-conversation--child-configuration-form configuration))) + (declare (ignore rendered)) + (setf second-worker worker)) + (evaluate first-worker + "(progn + (sb-thread:signal-semaphore (getf *shell-log-contention-fixture* :resume)) + (unless (sb-thread:wait-on-semaphore (getf *shell-log-contention-fixture* :done) :timeout 30) + (error \"First allocation did not publish\")) + (unless (typep (getf *shell-log-contention-fixture* :result) 'shell-log-artifact) + (error \"First allocation failed: ~S\" (getf *shell-log-contention-fixture* :result))))") + (evaluate second-worker + "(progn + (unless (sb-thread:wait-on-semaphore (getf *shell-log-contention-fixture* :done) :timeout 30) + (error \"Second allocation did not finish\")) + (unless (eq :quota-refused (getf *shell-log-contention-fixture* :result)) + (error \"Concurrent allocators overcommitted the single reservation\")))")) + (when second-worker (lisp-worker-stop second-worker)) + (when first-worker (lisp-worker-stop first-worker)))))) + nil) diff --git a/tests/test-suites.lisp b/tests/test-suites.lisp index 14b6345c..91ff21d8 100644 --- a/tests/test-suites.lisp +++ b/tests/test-suites.lisp @@ -156,7 +156,9 @@ test-shell-log-byte-windows-and-search test-shell-log-resource-authority test-shell-log-reopen-and-pruning - test-shell-log-capture-failure-metadata) + test-shell-log-capture-failure-metadata + test-shell-log-cross-process-lifecycle + test-shell-log-concurrent-allocation) (define-test-suite shell-log-job test-shell-log-job-results