diff options
| -rw-r--r-- | doc/ideas.rst | 14 | ||||
| -rw-r--r-- | src/deployment.lisp | 6 | ||||
| -rw-r--r-- | src/host.lisp | 8 | ||||
| -rw-r--r-- | src/package.lisp | 6 | ||||
| -rw-r--r-- | src/property.lisp | 10 | ||||
| -rw-r--r-- | src/propspec.lisp | 377 |
6 files changed, 191 insertions, 230 deletions
diff --git a/doc/ideas.rst b/doc/ideas.rst index c18b82d..c2996fa 100644 --- a/doc/ideas.rst +++ b/doc/ideas.rst @@ -56,12 +56,14 @@ Core useful surrounding a set of DEPLOYS applications, to concurrently deploy a number of hosts. -- A combinator which makes a list of properties unordered, i.e., later ones - don't depend on earlier ones. Then when applying, if we get FAILED-CHANGE, - we can just move on to the next property. The implicit dependency - relationships in the absence of this combinator is a good default, as almost - every defproplist will want that. But we might want to make this combinator - implicit in DEFHOST. +- It might be useful to have a restart for the case where an attempt is made + to apply a list of properties containing some ``:LISP`` properties with a + POSIX-type connection which applies properties up to but not including the + first ``:LISP`` property in the sequence, to get as much work as possible + done without violating any dependency relationships (``SEQPROPS`` already + handles wanting to apply all of the ``:POSIX`` properties in the sequence). + But maybe this is unnecessarily complex -- wouldn't it be better to just + fail and fix your deployment definitions? Project & packaging ------------------- diff --git a/src/deployment.lisp b/src/deployment.lisp index 91b46a8..4df5b59 100644 --- a/src/deployment.lisp +++ b/src/deployment.lisp @@ -33,7 +33,7 @@ connections in CONNECTIONS have been both normalised and preprocessed." (apply #'establish-connection type remaining args))) (if remaining (connect remaining) - (eval-propspec (host-propspec *host*))) + (propappapply (eval-propspec (host-propspec *host*)))) (connection-teardown *connection*))))) ;; make a partial own-copy of HOST so that connections can add new pieces ;; of required prerequisite data; specifically, so that they can request @@ -94,7 +94,7 @@ ADDITIONAL-PROPERTIES can override the host's usual static informational attributes, in the same way that later entries in the list of properties specified in DEFHOST forms can override earlier entries (see DEFHOST's docstring)." - `(deploy* ',connections ,host ,(props additional-properties))) + `(deploy* ',connections ,host (props eseqprops ,@additional-properties))) (defmacro deploy-these (connections host &body properties) "Like DEPLOY, except apply each of the properties specified by PROPERTIES, @@ -113,7 +113,7 @@ properties, plus any set by PROPERTIES. Static informational attributes set by PROPERTIES can override the host's usual static informational attributes, in the same way that later entries in the list of properties specified in DEFHOST forms can override earlier entries (see DEFHOST's docstring)." - `(deploy-these* ',connections ,host ,(props properties))) + `(deploy-these* ',connections ,host (props eseqprops ,@properties))) (defmacro defdeploy (name (connections host) &body additional-properties) "Define a function which does (DEPLOY CONNECTIONS HOST ADDITIONAL-PROPERTIES). diff --git a/src/host.lisp b/src/host.lisp index db028a7..88b26c5 100644 --- a/src/host.lisp +++ b/src/host.lisp @@ -47,10 +47,8 @@ be applied to the host."))) (defmethod %eval-propspec-hostattrs ((host host) (propspec propspec)) "Modify HOST in-place according to :HOSTATTRS subroutines." - (loop with *host* = host - for form in (propspec-props propspec) - for propapp = (compile-propapp form) - do (propappattrs propapp))) + (let ((*host* host)) + (propappattrs (eval-propspec propspec)))) ;; return values of the following two functions share structure, and thus are ;; not safe to use except on host objects that were just made, or that are @@ -107,7 +105,7 @@ entries." (declaim (type host ,hostname-sym)) (defparameter ,hostname-sym (%replace-propspec-into-host (make-instance 'host :attrs ',attrs) - ,(props properties)) + (props seqprops ,@properties)) ,(car (getf attrs :desc))) ,@(and deploy `((defdeploy ,hostname-sym (,deploy ,hostname-sym))))))) diff --git a/src/package.lisp b/src/package.lisp index 44652d5..356a537 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -102,7 +102,11 @@ ;; propspec.lisp #:in-consfig - #:make-propspec + #:seqprops + #:eseqprops + #:silent-seqprops + #:unapply + #:on-change ;; host.lisp #:host diff --git a/src/property.lisp b/src/property.lisp index 9c22d04..18572af 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -228,9 +228,10 @@ dotted name alongside NAME." "Define a property which applies a property application specification. ARGS is an ordinary lambda list, so you can use &AUX variables to compute intermediate values. PROPERTIES is an unevaluated property application -specification, but it will not be evaluated until the resulting property has -been added to a host, so it should not contain any free variables other than -as would be bound by (lambda ARGS). +specification where the implicit surrounding combinator is ESEQPROP, but it +will not be converted to a propspec until the resulting property has been +added to a host,so it should not contain any free variables other than as +would be bound by (lambda ARGS). The evaluation of PROPERTIES, and the evaluation of any &AUX variables, should not have any side effects. The evaluation will take place in the root Lisp. @@ -269,7 +270,8 @@ subroutines at the right time." ,@(cdr (pop properties))))) (setf (getf slots :preprocess) `(lambda (&rest all-args) - (cons (destructuring-bind ,args all-args ,(props properties)) + (cons (destructuring-bind ,args all-args + (props eseqprops ,@properties)) all-args))) `(eval-when (:compile-toplevel :load-toplevel :execute) (setprop ',name ,@slots) diff --git a/src/propspec.lisp b/src/propspec.lisp index 4e0dc8e..bb5fa71 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -19,71 +19,10 @@ ;;;; Property application specifications -(defmacro in-consfig (systems) - "Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS) -if SYSTEMS is an atom. Used at the top of your consfig, right after IN-PACKAGE. - -This is used to record a list of the names of the ASDF systems in which you -define your hosts, site-specific properties and deployments. These systems -should depend on the \"consfigurator\" system. - -SYSTEMS should satisfy the following condition: in normal usage of -Consfigurator, evaluating -(mapc #'asdf:load-system (if (atom SYSTEMS) (list SYSTEMS) SYSTEMS) should be -sufficient to define all the properties you intend to apply to hosts. - -Consfigurator uses this information when starting up remote Lisp images to -effect deployments: it sends over the ASDF systems specified by SYSTEMS." - (setq systems (ensure-cons systems)) - (let ((sym (intern "*CONSFIG*"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,sym ',systems - "ASDF systems the loading of all of which is sufficient to define all the -Consfigurator properties code in this symbol's package applies to hosts.")))) - -(defclass propspec () - ((systems - :initarg :systems - :initform (or (symbol-value (find-symbol "*CONSFIG*")) - (error - "Looks like *CONSFIG* is not set; please call IN-CONSFIG")) - :reader propspec-systems - :documentation "List of names of systems, the loading of all of which is -sufficient to deploy this propspec.") - (applications - :initarg :props - :reader propspec-props - :documentation "Ordered list of property applications. -The base case valid entry is of the form (PROPERTY . ARGS) where PROPERTY is -a symbol naming a property (typically as defined by DEFPROP) and ARGS is a -list of arguments to be passed when calling the property's subroutines. These -ARGS will not be evaluated before calling the function. - -Additionally, entries can be of the following forms: - - (unapply (PROPERTY . ARGS)) -- unapply the property, if it supports that. - - ((PROPERTY . ARGS) onchange (PROPERTY . ARGS) onchange (PROPERTY . ARGS)) - -- apply the second and third properties in the case that the first - property actually had work to do. - -... and combinations thereof. - -Deployments apply properties in the order specified here, so later entries in -the list implicitly depend on earlier ones. - -Members of ARGS must all be objects which can be serialised. In particular, -function objects are not permitted.")) - (:documentation - "The point of this data structure is to be a way to inform a Lisp image -running on a remote host how it can apply some properties: load each of the -systems, resolve unapply, onchange etc., and then look in the value cell of -each PROPERTY to find a property, and pass each of ARGS to the function in the -property's apply slot.")) - (defun map-propspec-propapps (function propspec &optional env) "Map FUNCTION over each propapp occurring in PROPSPEC after macroexpansion. -FUNCTION designates a pure function from propapps to propapps." +FUNCTION designates a pure function from propapps to propapps. PROPSPEC is a +property application specification expression." ;; The work of this function cannot be implemented fully portably. See ;; ;; Michael Raskin. 2017. Writing a best-effort portable code walker in @@ -124,167 +63,183 @@ FUNCTION designates a pure function from propapps to propapps." env))) env)))) -(defun make-propspec (&key (systems nil systems-supplied-p) props) - (setq props (copy-tree props)) - (labels ((preprocess (item) - (cond - ((and (listp item) (isprop (car item))) - (rplacd item (apply (proppp (car item)) (cdr item)))) - ((consp item) - (mapc #'preprocess item))))) - (preprocess props)) - (if systems-supplied-p - (make-instance 'propspec :props props :systems systems) - (make-instance 'propspec :props props))) +(defmacro in-consfig (systems) + "Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS) +if SYSTEMS is an atom. Used at the top of your consfig, right after IN-PACKAGE. + +This is used to record a list of the names of the ASDF systems in which you +define your hosts, site-specific properties and deployments. These systems +should depend on the \"consfigurator\" system. + +SYSTEMS should satisfy the following condition: in normal usage of +Consfigurator, evaluating +(mapc #'asdf:load-system (if (atom SYSTEMS) (list SYSTEMS) SYSTEMS) should be +sufficient to define all the properties you intend to apply to hosts and +property combinators you intend to use in specifying propspecs. + +Consfigurator uses this information when starting up remote Lisp images to +effect deployments: it sends over the ASDF systems specified by SYSTEMS." + (setq systems (ensure-cons systems)) + (let ((sym (intern "*CONSFIG*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,sym ',systems + "ASDF systems the loading of all of which is sufficient to define all the +Consfigurator properties and property combinators code in this symbol's +package applies to hosts.")))) -;; does not use MAKE-PROPSPEC because we do not want the :PREPROCESS -;; subroutines to be run again when the object is read back in +(defclass propspec () + ((systems + :initarg :systems + :initform (or (symbol-value (find-symbol "*CONSFIG*")) + (error + "Looks like *CONSFIG* is not set; please call IN-CONSFIG")) + :reader propspec-systems + :documentation + "List of names of ASDF systems, the loading of all of which is sufficient +to deploy this propspec.") + (preprocessed-propspec + :initarg :preprocessed-propspec + :documentation + "Preprocessed propspec corresponding to the propspec represented by this +PROPSPEC object. A preprocessed propspec is not itself a valid propspec, so +the value of this slot should be considered opaque.")) + (:documentation + "Object representing a propspec; specifically, a property application +specification expression associated with a list of ASDF systems. Use +MAKE-PROPSPEC to create instances of this class. + +The only valid methods operating directly on instances of this class are +PROPSPEC-SYSTEMS, APPEND-PROPSPECS, EVAL-PROPSPEC and PRINT-OBJECT.")) + +(defun make-propspec (&key (systems nil systems-supplied-p) propspec) + "Convert a property application specification expression into a property +application specification proper by associating it with a list of ASDF +systems." + (let ((preprocessed (map-propspec-propapps + (lambda (propapp) + (destructuring-bind (prop . args) propapp + `',(cons prop (apply (proppp prop) args)))) + propspec))) + (if systems-supplied-p + (make-instance 'propspec :systems systems + :preprocessed-propspec preprocessed) + (make-instance 'propspec :preprocessed-propspec preprocessed)))) + +;; since there are no unquoted propapps remaining in the propspec, we could +;; use MAKE-PROPSPEC here, but it is simpler just to use MAKE-INSTANCE (defmethod print-object ((propspec propspec) stream) (format stream "#.~S" `(make-instance 'propspec :systems ',(slot-value propspec 'systems) - :props ',(slot-value propspec 'applications))) + :preprocessed-propspec + ',(slot-value propspec 'preprocessed-propspec))) propspec) - -;; doesn't use MAKE-PROPSPEC because each of the propspecs will already have -;; had its :PREPROCESS subroutines run +;; likewise, there aren't any unquoted propapps in either of FIRST and SECOND, +;; so we could use MAKE-PROPSPEC, but it's simpler and more efficient not to (defmethod append-propspecs ((first propspec) (second propspec)) - (make-instance 'propspec - :props (append (slot-value first 'applications) - (slot-value second 'applications)) - :systems (loop with new = (slot-value first 'systems) - for s in (slot-value second 'systems) - do (pushnew s new) - finally (return new)))) - -;; All knowledge of the possible combinator symbols should be confined to -;; between here and the end of the file -- i.e., if we are to add any -;; combinators, this is the code that needs to change - -(defun compile-propapp (propapp) - "Recursively apply the effects of property combinators in PROPAPP to produce -an atomic property application." - (let ((sym (gensym))) - (cond - ;; UNAPPLY - ((symbol-named unapply (car propapp)) - (destructuring-bind (psym . args) (compile-propapp (cadr propapp)) - (setprop sym (proptype psym) - :desc (lambda (&rest args) - (strcat "Unapply: " (apply #'propdesc psym args))) - :check (complement (get psym 'check)) - :apply (get psym 'unapply) - :unapply (get psym 'apply)) - (cons sym args))) - ;; ON-CHANGE - ;; Following pretty much assumes that on-change is our only infix - ;; property combinator. - ((symbol-named on-change (cadr propapp)) - (let ((propapps (loop with remaining = (cdr propapp) - with apps - for s = (pop remaining) - for a = (pop remaining) - unless (symbol-named on-change s) - do (error "Invalid on-change expression") - else - do (push (compile-propapp a) apps) - unless remaining return apps))) - (destructuring-bind (psym . args) (compile-propapp (car propapp)) - (setprop sym (collapse-types (proptype psym) - (mapcar #'propapptype propapps)) - :desc (propdesc psym) - :hostattrs (lambda (&rest args) - (apply #'propattrs psym args) - (mapc #'propappattrs propapps)) - :check (get psym 'check) - :apply (lambda (&rest args) - (unless (eq :no-change - (apply psym args)) - (loop for propapp in propapps - do (propappapply propapp)))) - :unapply (lambda (&rest args) - (unless (eq :no-change - (apply #'propunapply psym args)) - (loop for propapp in propapps - do (propappapply propapp))))) - (cons sym args)))) - ;; atomic property application - (t - propapp)))) + (make-instance + 'propspec + :systems (union (slot-value first 'systems) + (slot-value second 'systems)) + :preprocessed-propspec `(silent-seqprops + ,(slot-value first 'preprocessed-propspec) + ,(slot-value second 'preprocessed-propspec)))) (defmethod eval-propspec ((propspec propspec)) - "Apply properties as specified by PROPSPEC." - ;; TODO should have this check in the closures produced by DEFPROP too, so - ;; that we will catch attempts to programmatically apply :LISP properties. - ;; for the check here, could offer a restart to apply all the properties up - ;; to but not including the first :LISP property (we don't just want to - ;; apply all non-:LISP because that might violate dependencies established - ;; by the order of the elements of PROPSPEC's props) - (when (and (subtypep (class-of *connection*) 'posix-connection) - (eq :lisp (propspec->type propspec))) - (error "Cannot apply :LISP properties using a POSIX connection")) ;; Don't try to load systems if we are a remote Lisp, as we don't upload the ;; .asd files, and we don't want to load out of /usr/share/common-lisp as we ;; might get a different version of the library at worst, or a lot of ;; warnings at best (unless *remote-lisp* - (loop for system in (slot-value propspec 'systems) - unless (asdf:component-loaded-p system) - do (asdf:load-system system))) - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - do (let ((change-made (not (eq :no-change (propappapply propapp))))) - (format t "~@[~A :: ~]~@[~A ... ~]~:[ok~;done~]~%" - (get-hostname) - (propappdesc propapp) - change-made)))) - -(defmethod propspec->type ((propspec propspec)) - "Return :lisp if any types of the properties to be applied by PROPSPEC is -:lisp, else return :posix." - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - if (eq (propapptype propapp) :lisp) - return :lisp - finally (return :posix))) - -(defun props (forms &optional (systems nil systems-supplied-p)) - "Where FORMS is the elements of an unevaluated property application -specification, return code which will evaluate the expressions and produce the -corresponding property application specification. - -SYSTEMS is the 'systems attribute of the property application specification -that the returned code should produce. - -Intended for use by macros which allow the user to provide expressions instead -of values as the arguments to properties when building a property application -specification." - (labels ((dedot-symbol (s) - (let ((n (symbol-name s))) - (intern (subseq n 0 (1- (length n))) (symbol-package s)))) - (special-eval (args) - (let ((first (if (and (listp (car args)) - (or (keywordp (caar args)) - (and (listp (caar args)) - (keywordp (caaar args))))) - `(quote ,(car args)) - (car args))) - (rest (nreverse (cdr (reverse (cdr args)))))) - `(,first ,@rest ,(props (lastcar args))))) - (make-eval-propspec (form) - (if (atom form) - `(quote ,form) - (destructuring-bind (first . rest) form - (if (and (symbolp first) - (not (member (symbol-name first) - '("UNAPPLY") - :test #'string=))) - (if (char= #\. (last-char (symbol-name first))) - `(list ',(dedot-symbol first) - ,@(special-eval rest)) - `(list ',first ,@rest)) - `(list ,@(mapcar #'make-eval-propspec form))))))) + (dolist (system (propspec-systems propspec)) + (unless (asdf:component-loaded-p system) + (asdf:load-system system)))) + (eval (slot-value propspec 'preprocessed-propspec))) + +(defmacro props (combinator &rest forms &aux replaced-propapps) + "Apply variadic COMBINATOR to FORMS and convert from an unevaluated property +application specification expression to a property application specification." + (labels ((replace-propapp (propapp) + (let ((gensym (gensym))) + (push (cons gensym propapp) replaced-propapps) + gensym)) + (walk (tree) + (if (atom tree) + (if-let ((propapp (assoc tree replaced-propapps))) + `(list ',(cadr propapp) ,@(cddr propapp)) + `',tree) + `(list ,@(mapcar #'walk tree))))) `(make-propspec - ,@(and systems-supplied-p `(:systems ,systems)) - :props (list ,@(mapcar #'make-eval-propspec forms))))) + :propspec ,(walk (map-propspec-propapps #'replace-propapp + (cons combinator forms)))))) + + +;;;; Property combinators + +(defmacro define-function-property-combinator (name args &body body) + (multiple-value-bind (forms declarations docstring) + (parse-body body :documentation t) + `(defun ,name ,args + ,@docstring + ,@declarations + (flet ((retprop (&rest all &key args &allow-other-keys) + (let ((psym (gensym)) + (setprop-args (remove-from-plist all :args))) + (apply #'setprop psym setprop-args) + (return-from ,name (list* psym args))))) + ,@forms)))) + +(define-function-property-combinator eseqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () (apply-and-print propapps)))) + +(define-function-property-combinator seqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () + (handler-bind + ((failed-change + (lambda (c) + (declare (ignore c)) + (invoke-restart 'skip-property)))) + (apply-and-print propapps))))) + +(define-function-property-combinator silent-seqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () + (handler-bind + ((failed-change + (lambda (c) + (declare (ignore c)) + (invoke-restart 'skip-property)))) + (mapc #'propappapply propapps))))) + +;; note that the :FAILED-CHANGE value is only used within this function and +;; should not be returned by property subroutines, per the spec +(defun apply-and-print (propapps) + (dolist (propapp propapps) + (let* ((result (restart-case (propappapply propapp) + (skip-property () :failed-change))) + (status (case result + (:no-change "ok") + (:failed-change "failed") + (t "done")))) + (format t "~@[~A :: ~]~@[~A ... ~]~A~%" + (get-hostname) (propappdesc propapp) status)))) + +(define-function-property-combinator unapply (propapp) + (destructuring-bind (psym . args) propapp + (retprop :type (proptype psym) + :lambda (propargs psym) + :desc (lambda (&rest args) + (strcat "Unapply: " (apply #'propdesc psym args))) + :check (complement (get psym 'check)) + :apply (get psym 'unapply) + :unapply (get psym 'apply) + :args args))) |