diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-07-05 16:29:46 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-07-10 20:45:21 -0700 |
commit | 56bc5a2c24b0fe56c72ced9a5ac85d982d592567 (patch) | |
tree | d01d1820afeadd4d50794e45007bba9d9533b373 /src | |
parent | ec508517bc89d3934afa9ec91f3787839b14be2d (diff) | |
download | consfigurator-56bc5a2c24b0fe56c72ced9a5ac85d982d592567.tar.gz |
signal SKIPPED-PROPERTIES & factor out interpreting exit codes
Unconditionally signalling FAILED-CHANGE does not make sense because perhaps
the type of condition C is not a subtype of SIMPLE-CONDITION. Moreover, when
we invoke the SKIP-PROPERTY restart we do not actually pass the condition.
For simplicity, and since all we need is notification that a SKIP-PROPERTY
restart was invoked, instead define and signal a special-purpose condition.
Additionally, use an exit code to pass the signal between Lisp images.
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src')
-rw-r--r-- | src/combinator.lisp | 7 | ||||
-rw-r--r-- | src/connection/fork.lisp | 16 | ||||
-rw-r--r-- | src/connection/sbcl.lisp | 15 | ||||
-rw-r--r-- | src/data.lisp | 8 | ||||
-rw-r--r-- | src/deployment.lisp | 16 | ||||
-rw-r--r-- | src/package.lisp | 3 | ||||
-rw-r--r-- | src/util.lisp | 55 |
7 files changed, 69 insertions, 51 deletions
diff --git a/src/combinator.lisp b/src/combinator.lisp index 68642ea..220b61e 100644 --- a/src/combinator.lisp +++ b/src/combinator.lisp @@ -151,11 +151,8 @@ apply the elements of REQUIREMENTS in reverse order." (restart-case (if announce (announce-propapp-apply propapp) (propapp-apply propapp)) - (skip-property (c) - ;; Re-signal as a non-error, for notification purposes. - (signal 'failed-change - :format-control (simple-condition-format-control c) - :format-arguments (simple-condition-format-arguments c)) + (skip-property () + (signal 'skipped-properties) 'failed-change))) (when (and (plusp (length buffer)) (or (> *consfigurator-debug-level* 1) diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp index 169552d..1eb6568 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -66,7 +66,7 @@ for example, such that we don't see it." (-1 (error "fork(2) failed")) (0 - (with-backtrace-and-exit-code-two + (with-backtrace-and-exit-code ;; Capture child stdout in case *STANDARD-OUTPUT* has been rebound ;; to somewhere else in the parent, e.g. by APPLY-AND-PRINT. The ;; parent can then send the contents of the file named by OUTPUT to @@ -89,10 +89,7 @@ for example, such that we don't see it." ;; (establish-connection :local)) here, but we need to kill off ;; the child afterwards, rather than returning to the child's ;; REPL or whatever else. - (uiop:quit - (if (eql :no-change (continue-deploy* connection remaining)) - 0 - 1))))) + (continue-deploy* connection remaining)))) (t (multiple-value-bind (pid status) (waitpid child 0) (declare (ignore pid)) @@ -104,7 +101,8 @@ for example, such that we don't see it." "Fork connection child did not exit normally, status #x~(~4,'0X~)" status)) (let ((exit-status (wexitstatus status))) - (unless (< exit-status 2) - (failed-change - "Fork connection child failed, exit code ~D" exit-status)) - (values nil (and (zerop status) :no-change)))))))))) + (return-exit + exit-status + :on-failure + (failed-change "Fork connection child failed, exit code ~D" + exit-status)))))))))) diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp index fb862aa..ed68243 100644 --- a/src/connection/sbcl.lisp +++ b/src/connection/sbcl.lisp @@ -56,13 +56,14 @@ recommended.")) (multiple-value-bind (program forms) (continue-deploy*-program remaining requirements) (multiple-value-bind (out err exit) (run :may-fail :input program *sbcl*) - (inform t (if (< exit 2) "done." "failed.") :fresh-line nil) + (inform t (if (< exit 3) "done." "failed.") :fresh-line nil) (when-let ((lines (lines out))) (inform t " Output was:" :fresh-line nil) (with-indented-inform (inform t lines))) - (unless (< exit 2) - ;; print FORMS not PROGRAM because latter might contain sudo passwords - (failed-change - "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S" - err forms)) - (values nil (if (zerop exit) :no-change nil)))))) + (return-exit + exit + ;; print FORMS not PROGRAM because latter might contain sudo passwords + :on-failure + (failed-change + "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S" + err forms)))))) diff --git a/src/data.lisp b/src/data.lisp index 80a72be..c7f4094 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -714,12 +714,8 @@ Preprocessing must occur in the root Lisp.")) finally (setq record accum))) ;; Continue the deployment. ,(wrap - `(with-backtrace-and-exit-code-two - (uiop:quit - (if (eql :no-change - (%consfigure ',remaining-connections ,*host*)) - 0 - 1))))))) + `(with-backtrace-and-exit-code + (%consfigure ',remaining-connections ,*host*)))))) (handler-case (with-standard-io-syntax (let ((*allow-printing-passphrases* t)) diff --git a/src/deployment.lisp b/src/deployment.lisp index ce4fb95..a845168 100644 --- a/src/deployment.lisp +++ b/src/deployment.lisp @@ -91,22 +91,6 @@ will not be discarded." (make-propspec :propspec propspec-expression))) :collect-at-end collect-at-end)) -(defmacro with-deployment-report (&rest forms) - (with-gensyms (failures) - `(let (,failures) - (handler-bind ((failed-change (lambda (c) (setq ,failures t)))) - (let ((result (progn ,@forms))) - (inform - t - (cond - ((eql :no-change result) - "No changes were made.") - (,failures - "There were failures while attempting to apply some properties.") - (t - "Changes were made without any reported failures."))) - result))))) - (defun deploy* (connections host &optional additional-properties) "Execute the deployment which is defined by the pair (CONNECTIONS . HOST), except possibly with the property application specification diff --git a/src/package.lisp b/src/package.lisp index bb63089..e4b3e50 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -107,7 +107,8 @@ #:unwind-protect-in-parent #:cancel-unwind-protect-in-parent-cleanup - #:with-backtrace-and-exit-code-two + #:with-backtrace-and-exit-code + #:return-exit #:posix-login-environment ;; connection.lisp diff --git a/src/util.lisp b/src/util.lisp index 24ec85e..7dadfe9 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -453,13 +453,54 @@ of this macro." Should be called soon after fork(2) in child processes." (signal 'in-child-process)) -(defmacro with-backtrace-and-exit-code-two (&body forms) - `(handler-bind - ((serious-condition - (lambda (c) - (trivial-backtrace:print-backtrace c :output *error-output*) - (uiop:quit 2)))) - ,@forms)) +(define-condition skipped-properties () () + (:documentation + "There were failed changes, but instead of aborting, that particular property +application was instead skipped over, either due to the semantics of a +property combinator, or because the user elected to skip the property in the +interactive debugger.")) + +(defmacro with-deployment-report (&rest forms) + (with-gensyms (failures) + `(let* (,failures + (result (handler-bind ((skipped-properties (lambda (c) + (declare (ignore c)) + (setq ,failures t)))) + ,@forms))) + (inform + t + (cond + ((eql :no-change result) + "No changes were made.") + (,failures + "There were failures while attempting to apply some properties.") + (t + "Changes were made without any reported failures.")))))) + +(defmacro with-backtrace-and-exit-code (&body forms) + (with-gensyms (failures) + `(let* (,failures + (result (handler-bind ((serious-condition + (lambda (c) + (trivial-backtrace:print-backtrace + c :output *error-output*) + (uiop:quit 3))) + (skipped-properties (lambda (c) + (declare (ignore c)) + (setq ,failures t)))) + ,@forms))) + (uiop:quit (cond ((eql :no-change result) 0) + (,failures 2) + (t 1)))))) + +(defmacro return-exit (exit &key on-failure) + `(values + nil + (case ,exit + (0 :no-change) + (1 nil) + (2 (signal 'skipped-properties) nil) + (t ,on-failure)))) (defun posix-login-environment (logname home) "Reset the environment after switching UID, or similar, in a :LISP connection. |