add WITH-THESE-OPEN-VOLUMES macro property combinator

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

5 files changed, 78 insertions, 0 deletions

diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index f73bbed..ef1cd7c 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -73,6 +73,7 @@ for example, such that we don't see it."
                           (uiop:quit 2))))
          (mapc #'clear-input
                (list *standard-input* *debug-io* *terminal-io*))
+         (cancel-unwind-protect-in-parent-cleanup)
          ;; While some kinds of data source will still work given certain
          ;; subtypes of FORK-CONNECTION (e.g. if they've already cached the
          ;; data in memory, or if it's also accessible to whomever we will
diff --git a/src/host.lisp b/src/host.lisp
index ba40886..f03c662 100644
--- a/src/host.lisp
+++ b/src/host.lisp
@@ -62,6 +62,16 @@ properties."
   `(let ((*host* (shallow-copy-host *host*)))
      ,@forms))
 
+(defmacro with-replace-hostattrs ((&rest hostattrs) &body forms)
+  "Remove all hostattrs for each hostattr type in HOSTATTRS, execute forms,
+then restore previous hostattrs, including throwing away any newly added
+hostattrs.  Useful in property combinators which create context by replacing
+hostattrs.  Shouldn't be used in properties."
+  `(with-preserve-hostattrs
+     ,@(loop for type in hostattrs
+             collect `(setf (getf (slot-value *host* 'hostattrs) ,type) nil))
+     ,@forms))
+
 (defgeneric preprocess-host (host)
   (:documentation
    "Convert a host into a fresh preprocessed host if necessary, and
diff --git a/src/package.lisp b/src/package.lisp
index 64871bc..fe31025 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -79,6 +79,9 @@
            #:string->filename
            #:filename->string
 
+           #:unwind-protect-in-parent
+           #:cancel-unwind-protect-in-parent-cleanup
+
            ;; connection.lisp
            #:establish-connection
            #:continue-connection
@@ -166,6 +169,7 @@
            #:hostattrs
            #:preprocess-host
            #:with-preserve-hostattrs
+           #:with-replace-hostattrs
 
            ;; deployment.lisp
            #:defdeploy
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 9e8e55f..ecc26c8 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -503,6 +503,42 @@ populate /etc/fstab and /etc/crypttab.  Do not modify this list."
          (unwind-protect (progn ,@forms)
            ,(with-mount-below `(mapc #'close-volume ,opened-volumes)))))))
 
+(defmacro with-these-open-volumes
+    ((volumes &key (mount-below nil mount-below-supplied-p)) &body propapps)
+  "Macro property combinator.  Where each of VOLUMES is a VOLUME which may be
+opened by calling OPEN-VOLUME with NIL as the second argument, recursively
+open each of VOLUMES and any contents thereof, apply PROPAPPS, and close all
+volumes that were opened.
+
+MOUNT-BELOW specifies a pathname to prefix to mount points when opening
+FILESYSTEM volumes.  During the application of PROPAPPS, all :OPENED-VOLUMES
+hostattrs are replaced with a list of the volumes that were opened; this list
+must not be modified."
+  `(with-these-open-volumes*
+     ,volumes
+     ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps))
+     ,@(and mount-below-supplied-p `(:mount-below ,mount-below))))
+
+(define-function-property-combinator with-these-open-volumes*
+    (volumes propapp &key (mount-below nil mount-below-supplied-p))
+  (:retprop
+   :type (propapptype propapp)
+   :hostattrs (get (car propapp) 'hostattrs)
+   :apply
+   (lambda (&rest ignore)
+     (declare (ignore ignore))
+     (let ((opened-volumes
+             (apply #'open-volumes-and-contents
+                    `(,volumes ,@(and mount-below-supplied-p
+                                      `(:mount-below ,mount-below))))))
+       (unwind-protect-in-parent
+           (with-replace-hostattrs (:opened-volumes)
+             (apply #'push-hostattrs
+                    :opened-volumes opened-volumes)
+             (propappapply propapp))
+         (with-mount-below (mapc #'close-volume opened-volumes)))))
+   :args (cdr propapp)))
+
 (defmethod create-volume-and-contents ((volume volume) file)
   "Recursively create VOLUME and its contents, on or at FILE.
 **THIS METHOD UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA**"
diff --git a/src/util.lisp b/src/util.lisp
index 2d024ca..a1523d0 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -264,3 +264,30 @@ previous output."
              (t
               (push c result)))
         finally (return (coerce (nreverse result) 'string))))
+
+
+;;;; Forking utilities
+
+(define-condition in-child-process () ())
+
+(defmacro unwind-protect-in-parent (protected &body cleanup)
+  "Like UNWIND-PROTECT, but with a mechanism to cancel the execution of CLEANUP
+in child processes resulting from calls to fork(2) during the execution of
+PROTECTED.  This means that CLEANUP won't get executed on both sides of the
+fork, but only in the parent.
+
+For this to work, after fork(2), the child process must call
+CANCEL-UNWIND-PROTECT-IN-PARENT-CLEANUP, which will affect all enclosing uses
+of this macro."
+  (with-gensyms (cancelled)
+    `(let (,cancelled)
+       (unwind-protect
+            (handler-bind ((in-child-process
+                             (lambda (c) (setq ,cancelled t) (signal c))))
+              ,protected)
+         (unless ,cancelled ,@cleanup)))))
+
+(defun cancel-unwind-protect-in-parent-cleanup ()
+  "Cancel the CLEANUP forms in all enclosing uses of UNWIND-PROTECT-IN-PARENT.
+Should be called soon after fork(2) in child processes."
+  (signal 'in-child-process))