add HOSTDEPLOY, HOSTDEPLOY-THESE

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

4 files changed, 47 insertions, 9 deletions

diff --git a/doc/ideas.rst b/doc/ideas.rst
index 1209e7d..1b949eb 100644
--- a/doc/ideas.rst
+++ b/doc/ideas.rst
@@ -49,10 +49,6 @@ Core
   calling its :HOSTATTRS subroutine too -- could we figure out catching and
   ignoring the condition when its :HOSTATTRS subroutine did get run?
 
-- HOSTDEPLOY and HOSTDEPLOY-THESE functions which are like DEPLOY and
-  DEPLOY-THESE but take the CONNECTION argument from the :DEPLOY argument to
-  DEFHOST.
-
 - A CONCURRENTLY combinator for property application specifications, which
   means to apply each of the enclosed properties in parallel.  Particularly
   useful surrounding a set of DEPLOYS applications, to concurrently deploy a
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 3b77168..cd5c5a7 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -161,6 +161,36 @@ You can then eval (NAME) to execute this deployment."
   `(defun ,name ()
      (deploy-these ,connections ,host ,@properties)))
 
+(defun hostdeploy* (host &optional additional-properties)
+  "Like DEPLOY*, but use the host's default deployment."
+  (deploy* (or (host-deployment host)
+               (simple-program-error "Host has no default deployment"))
+           host
+           additional-properties))
+
+(defun hostdeploy-these* (host properties)
+  "Like DEPLOY-THESE*, but use the host's default deployment."
+  (deploy-these* (or (host-deployment host)
+                     (simple-program-error "Host has no default deployment"))
+                 host
+                 properties))
+
+(defmacro hostdeploy (host &body additional-properties)
+  "Like DEPLOY, but use the host's default deployment."
+  (once-only (host)
+    `(hostdeploy* ,host
+                  (let ((*host* (shallow-copy-host ,host)))
+                    (make-propspec
+                     :propspec (props eseqprops ,@additional-properties))))))
+
+(defmacro hostdeploy-these (host &body properties)
+  "Like DEPLOY-THESE, but use the host's default deployment."
+  (once-only (host)
+    `(hostdeploy-these* ,host
+                        (let ((*host* (shallow-copy-host ,host)))
+                          (make-propspec
+                           :propspec (props eseqprops ,@properties))))))
+
 (defprop deploys :posix (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/host.lisp b/src/host.lisp
index 602927b..ba40886 100644
--- a/src/host.lisp
+++ b/src/host.lisp
@@ -28,7 +28,13 @@
    (propspec
     :initarg :propspec
     :reader host-propspec
-    :documentation "Propspec of the properties to be applied to the host."))
+    :documentation "Propspec of the properties to be applied to the host.")
+   (default-deployment
+    :initform nil
+    :initarg :deploy
+    :reader host-deployment
+    :documentation
+    "Connection chain representing the usual way this host is deployed."))
   (:documentation "Abstract superclass for hosts.  Do not instantiate."))
 
 (defclass preprocessed-host (host)
@@ -75,9 +81,9 @@ values higher up the call stack."))
     (propappattrs (eval-propspec (host-propspec *host*)))
     *host*))
 
-(defun make-host (&key hostattrs (propspec (make-propspec)))
+(defun make-host (&key hostattrs (propspec (make-propspec)) deploy)
   (make-instance 'unpreprocessed-host
-                 :hostattrs hostattrs :propspec propspec))
+                 :hostattrs hostattrs :propspec propspec :deploy deploy))
 
 (defun make-child-host (&key hostattrs propspec)
   "Make a host object to represent a chroot, container or the like.
@@ -91,7 +97,8 @@ Called by properties which set up such subhosts, like CHROOT:OS-BOOTSTRAPPED."
   (format stream "#.~S" `(make-instance
                           ',(type-of host)
                           :hostattrs ',(slot-value host 'hostattrs)
-                          :propspec ,(slot-value host 'propspec)))
+                          :propspec ,(slot-value host 'propspec)
+                          :deploy ',(slot-value host 'default-deployment)))
   host)
 
 (defmethod union-propspec-into-host
@@ -148,7 +155,8 @@ entries."
        (defparameter ,hostname-sym
          (make-host :hostattrs ',attrs
                     :propspec (make-propspec
-                               :propspec (props seqprops ,@properties)))
+                               :propspec (props seqprops ,@properties))
+                    :deploy ',deploy)
          ,(car (getf attrs :desc)))
        ,@(and deploy
               `((defdeploy ,hostname-sym (,deploy ,hostname-sym)))))))
diff --git a/src/package.lisp b/src/package.lisp
index fd6ec12..ac6bbe7 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -174,6 +174,10 @@
            #:deploys-these.
            #:deploy-these*
            #:deploys-these
+           #:hostdeploy
+           #:hostdeploy*
+           #:hostdeploy-these
+           #:hostdeploy-these*
            #:continue-deploy*
 
            ;; data.lisp