diff options
-rw-r--r-- | doc/ideas.rst | 4 | ||||
-rw-r--r-- | src/deployment.lisp | 30 | ||||
-rw-r--r-- | src/host.lisp | 18 | ||||
-rw-r--r-- | src/package.lisp | 4 |
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 |