propagate :NO-CHANGE out of fork subdeployments

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

2 files changed, 32 insertions, 18 deletions

diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index be392cd..989668c 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -29,6 +29,12 @@
   ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does
   #+sbcl (sb-posix:waitpid pid options))
 
+(defun wifexited (status)
+  #+sbcl (sb-posix:wifexited status))
+
+(defun wexitstatus (status)
+  #+sbcl (sb-posix:wexitstatus status))
+
 (defun can-probably-fork ()
   "Return nil if we can detect other running threads, and the Lisp
 implementation is known not to support forking when there are other threads.
@@ -78,15 +84,20 @@ 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.
-         (continue-deploy* remaining)
-         (uiop:quit 0)))
+         (uiop:quit
+          (if (eql :no-change (continue-deploy* remaining))
+              0
+              1))))
       (t
-       (multiple-value-bind (_ status) (waitpid child 0)
-         (declare (ignore _))
-         (unless (zerop status)
-           ;; TODO instead of parsing the status ourselves here, maybe we
-           ;; can call the various C macros for parsing the status in wait(2)
-           (error
-            "Fork connection child failed, status #x~(~4,'0X~)" status)))
-       ;; return nil to %CONSFIGURE
-       nil))))
+       (multiple-value-bind (pid status) (waitpid child 0)
+         (declare (ignore pid))
+         (let ((exited (wifexited status)))
+           (unless exited
+             (error
+              "Fork connection child did not exit normally, status #x~(~4,'0X~)"
+              status))
+           (let ((exit-status (wexitstatus status)))
+             (unless (< exit-status 2)
+               (error
+                "Fork connection child failed, exit code ~D" exit-status))
+             (values nil (if (zerop status) :no-change nil)))))))))
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 1937270..472ba4b 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -33,13 +33,16 @@ preprocessed."
        (connect (connections)
          (destructuring-bind ((type . args) . remaining) connections
            ;; implementations of ESTABLISH-CONNECTION which call
-           ;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM return nil to us
-           (when-let ((*connection*
-                       (apply #'establish-connection type remaining args)))
-             (if remaining
-                 (connect remaining)
-                 (apply-*host*-propspec))
-             (connection-teardown *connection*)))))
+           ;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM return nil to us,
+           ;; and possibly :NO-CHANGE as a second value
+           (multiple-value-bind (*connection* return)
+               (apply #'establish-connection type remaining args)
+             (if *connection*
+                 (prog1 (if remaining
+                            (connect remaining)
+                            (apply-*host*-propspec))
+                   (connection-teardown *connection*))
+                 return)))))
     (let ((*host* (preprocess-host host)))
       (cond
         ((and connections (or *connection* (eq :local (caar connections))))