call :PREPROCESS and :HOSTATTRS subroutines later

Avoids us trying to eval propspecs at DEFHOST time, which can get us into ASDF
loading loops.

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

5 files changed, 120 insertions, 83 deletions

diff --git a/src/data.lisp b/src/data.lisp
index 70c75e7..b28a24a 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -359,6 +359,10 @@ The program returned is a single string consisting of a number of sexps
 separated by newlines.  Each sexp must be evaluated by the remote Lisp image
 before the following sexp is offered to its reader.  Usually this can be
 achieved by sending the return value of this function into a REPL's stdin."
+  (unless (eq (type-of *host*) 'preprocessed-host)
+    (error "Attempt to send unpreprocessed host to remote Lisp.
+
+Preprocessing must occur in the root Lisp."))
   (flet ((wrap (forms)
 	   `(handler-bind
 		(;; we can skip missing data sources because these are not
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 4df5b59..54dc2c6 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -35,10 +35,7 @@ connections in CONNECTIONS have been both normalised and preprocessed."
 		 (connect remaining)
 		 (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
-    ;; the source code of ASDF systems
-    (let ((*host* (shallow-copy-host host)))
+    (let ((*host* (preprocess-host host)))
       (connect (if (eq :local (caar connections))
 		   connections
 		   (cons '(:local) connections))))))
@@ -136,9 +133,11 @@ Useful to have one host act a controller, applying properties to other hosts.
 Also useful to set up VMs, chroots, disk images etc. on localhost."
   (:preprocess
    (list (preprocess-connections connections)
-	 (if additional-properties
-	     (%union-propspec-into-host host additional-properties)
-	     host)))
+	 (preprocess-host
+	  (if additional-properties
+	      (%union-propspec-into-host (shallow-copy-host host)
+					 additional-properties)
+	      host))))
   (:hostattrs
    (declare (ignore connections additional-properties))
    (%propagate-hostattrs host))
@@ -152,7 +151,8 @@ PROPERTIES, and not the host's usual properties, unless they also appear in
 PROPERTIES, like DEPLOY-THESE."
   (:preprocess
    (list (preprocess-connections connections)
-	 (%replace-propspec-into-host host properties)))
+	 (preprocess-host
+	  (%replace-propspec-into-host (shallow-copy-host host) properties))))
   (:hostattrs
    (declare (ignore connections properties))
    (%propagate-hostattrs host))
@@ -165,10 +165,6 @@ PROPERTIES, like DEPLOY-THESE."
 	collect (apply #'preprocess-connection-args
 		       (ensure-cons connection))))
 
-(defun shallow-copy-host (host)
-  (make-instance 'host :props (host-propspec host)
-		       :attrs (copy-list (hostattrs host))))
-
 (defun %propagate-hostattrs (host)
   (dolist (system (propspec-systems (host-propspec host)))
     (pushnew system (slot-value (host-propspec *host*) 'systems)))
diff --git a/src/host.lisp b/src/host.lisp
index 88b26c5..4facea6 100644
--- a/src/host.lisp
+++ b/src/host.lisp
@@ -19,54 +19,78 @@
 
 ;;;; Hosts
 
-;; note that we expect any host object to be such that the :HOSTATTRS
-;; subroutines of its propspec has already been run.  so, run them when
-;; instantiating a new object, as DEFHOST does.
 (defclass host ()
   ((hostattrs
-    :initarg :attrs
+    :initarg :hostattrs
     :reader hostattrs
     :documentation "Plist of the host's static informational attributes.")
    (propspec
-    :initarg :props
+    :initarg :propspec
     :reader host-propspec
-    :documentation "Property application specification of the properties to
-be applied to the host.")))
-
-(defun make-host (&key hostattrs props)
-  (let ((host (make-instance 'host :attrs hostattrs :props props)))
-    (%eval-propspec-hostattrs host props)
-    host))
+    :documentation "Propspec of the properties to be applied to the host."))
+  (:documentation "Abstract superclass for hosts.  Do not instantiate."))
+
+(defclass preprocessed-host (host)
+  ((propspec
+    :type preprocessed-propspec))
+  (:documentation
+   "A host whose :PREPROCESS and :HOSTATTRS subroutines have been run."))
+
+(defclass unpreprocessed-host (host)
+  ((propspec
+    :type unpreprocessed-propspec))
+  (:documentation
+   "A host whose :PREPROCESS and :HOSTATTRS subroutines have not been run."))
+
+(defmethod shallow-copy-host ((host host))
+  (make-instance (type-of host)
+		 :hostattrs (copy-list (hostattrs host))
+		 :propspec (host-propspec host)))
+
+(defgeneric preprocess-host (host)
+  (:documentation
+   "Convert a host into a fresh preprocessed host if necessary, and
+unconditionally perform a shallow copy of the plist of static information
+attributes, so that implementations of ESTABLISH-CONNECTION can push new
+attributes (typically to request prerequisite data) without disturbing host
+values higher up the call stack."))
+
+(defmethod preprocess-host ((host preprocessed-host))
+  (shallow-copy-host host))
+
+(defmethod preprocess-host ((host unpreprocessed-host))
+  (let ((*host* (make-instance
+		 'preprocessed-host
+		 :hostattrs (copy-list (hostattrs host))
+		 :propspec (preprocess-propspec (host-propspec host)))))
+    (propappattrs (eval-propspec (host-propspec *host*)))
+    *host*))
+
+(defun make-host (&key hostattrs propspec)
+  (make-instance 'unpreprocessed-host
+		 :hostattrs hostattrs :propspec propspec))
 
 (defmethod print-object ((host host) stream)
   (format stream "#.~S" `(make-instance
-			  'host
-			  :attrs ',(slot-value host 'hostattrs)
-			  :props ,(slot-value host 'propspec)))
+			  ',(type-of host)
+			  :hostattrs ',(slot-value host 'hostattrs)
+			  :propspec ,(slot-value host 'propspec)))
   host)
 
-(defmethod %eval-propspec-hostattrs ((host host) (propspec propspec))
-  "Modify HOST in-place according to :HOSTATTRS subroutines."
-  (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
 ;; going straight into %CONSFIGURE
 
-(defmethod %union-propspec-into-host ((host host) (propspec propspec))
-  (prog1
-      (setq host (make-instance 'host
-				:attrs (hostattrs host)
-				:props (append-propspecs (host-propspec host)
-							 propspec)))
-    (%eval-propspec-hostattrs host propspec)))
+(defmethod %union-propspec-into-host
+    ((host unpreprocessed-host) (propspec propspec))
+  (make-instance 'unpreprocessed-host
+		 :hostattrs (hostattrs host)
+		 :propspec (append-propspecs (host-propspec host) propspec)))
 
-(defmethod %replace-propspec-into-host ((host host) (propspec propspec))
-  (prog1
-      (setq host (make-instance 'host
-				:attrs (hostattrs host) :props propspec))
-    (%eval-propspec-hostattrs host propspec)))
+(defmethod %replace-propspec-into-host
+    ((host unpreprocessed-host) (propspec unpreprocessed-propspec))
+  (make-instance 'unpreprocessed-host
+		 :hostattrs (hostattrs host) :propspec propspec))
 
 (defmacro defhost (hostname (&key deploy) &body properties)
   "Define a host with hostname HOSTNAME and properties PROPERTIES.
@@ -104,7 +128,7 @@ entries."
     `(progn
        (declaim (type host ,hostname-sym))
        (defparameter ,hostname-sym
-	 (%replace-propspec-into-host (make-instance 'host :attrs ',attrs)
+	 (%replace-propspec-into-host (make-host :hostattrs ',attrs)
 				      (props seqprops ,@properties))
 	 ,(car (getf attrs :desc)))
        ,@(and deploy
diff --git a/src/package.lisp b/src/package.lisp
index 356a537..7b93f2d 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -102,6 +102,8 @@
 
 	   ;; propspec.lisp
 	   #:in-consfig
+	   #:make-propspec
+	   #:append-propspecs
 	   #:seqprops
 	   #:eseqprops
 	   #:silent-seqprops
diff --git a/src/propspec.lisp b/src/propspec.lisp
index 7072133..1966023 100644
--- a/src/propspec.lisp
+++ b/src/propspec.lisp
@@ -130,66 +130,77 @@ package applies to hosts."))))
     :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
+to evaluate and to deploy this propspec."))
+  (:documentation
+   "Abstract superclass for propspecs.  Do not instantiate."))
+
+(defclass preprocessed-propspec (propspec)
+  ((preprocessed-propspec-expression
+    :initarg :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."))
+object.  A preprocessed propspec is not itself a valid propspec, so the value
+of this slot should be considered opaque."))
+  (:documentation
+   "A propspec which has been preprocessed.  The only valid methods operating
+directly on instances of this class are PROPSPEC-SYSTEMS, EVAL-PROPSPEC and
+PRINT-OBJECT."))
+
+(defclass unpreprocessed-propspec (propspec)
+  ((propspec-expression
+    :initarg :propspec
+    :reader propspec-props)))
+
+(defgeneric preprocess-propspec (propspec)
   (: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.
+   "Quote all propapps in PROPSPEC, after calling :PREPROCESS subroutines."))
 
-The only valid methods operating directly on instances of this class are
-PROPSPEC-SYSTEMS, APPEND-PROPSPECS, EVAL-PROPSPEC and PRINT-OBJECT."))
+(defmethod preprocess-propspec ((propspec unpreprocessed-propspec))
+  (make-instance 'preprocessed-propspec
+		 :systems (propspec-systems propspec)
+		 :propspec (map-propspec-propapps
+			    (lambda (propapp)
+			      (destructuring-bind (prop . args) propapp
+				`',(cons prop (apply (proppp prop) args))))
+			    (propspec-props propspec))))
 
 (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)
+  (if systems-supplied-p
+      (make-instance 'unpreprocessed-propspec
+		     :systems systems :propspec propspec)
+      (make-instance 'unpreprocessed-propspec :propspec propspec)))
+
+(defmethod print-object ((propspec preprocessed-propspec) stream)
   (format stream "#.~S" `(make-instance
-			  'propspec
+			  'preprocessed-propspec
 			  :systems ',(slot-value propspec 'systems)
-			  :preprocessed-propspec
-			  ',(slot-value propspec 'preprocessed-propspec)))
+			  :propspec
+			  ',(slot-value propspec
+					'preprocessed-propspec-expression)))
   propspec)
 
-;; 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
-   :systems (union (slot-value first 'systems)
-		   (slot-value second 'systems))
-   :preprocessed-propspec `(silent-seqprops
-			    ,(slot-value first 'preprocessed-propspec)
-			    ,(slot-value second 'preprocessed-propspec))))
+;; this could be defined for preprocessed propspecs easily enough but we
+;; shouldn't need to append those
+(defmethod append-propspecs
+    ((first unpreprocessed-propspec) (second unpreprocessed-propspec))
+  (make-propspec :systems (union (propspec-systems first)
+				 (propspec-systems second))
+		 :propspec `(silent-seqprops ,(propspec-props first)
+					     ,(propspec-props second))))
 
 (defvar *suppress-loading-systems* nil
   "Bound by code which needs to prevent EVAL-PROPSPEC from attempting to load
 the ASDF systems associated with the propspec to be evaluated.")
 
-(defmethod eval-propspec ((propspec propspec))
+(defmethod eval-propspec ((propspec preprocessed-propspec))
   (unless *suppress-loading-systems*
     (dolist (system (propspec-systems propspec))
       (unless (asdf:component-loaded-p system)
 	(asdf:load-system system))))
-  (eval (slot-value propspec 'preprocessed-propspec)))
+  (eval (slot-value propspec 'preprocessed-propspec-expression)))
 
 (define-condition ambiguous-unevaluated-propspec (ambiguous-propspec) ()
   (:report