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>

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.