separately upload, compile and load each ASDF system

This avoids recompiling unchanged systems on every deploy, which makes for a
decent performance boost, especially on systems with less processing power.

Drop the idea of relying on distribution packages on the remote side -- we
want to use the same version of the source as is running in the root Lisp.

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

6 files changed, 205 insertions, 137 deletions

diff --git a/src/connection.lisp b/src/connection.lisp
index 508f775..2ac43d7 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -473,12 +473,12 @@ connattr, or nil if nothing should be propagated.")
                (when-let ((new (propagate-connattr k v connection)))
                  (setf (getf (slot-value connection 'connattrs) k) new))))))
 
-(defun get-connattr (k)
+(defun get-connattr (k &optional (connection *connection*))
   "Get the connattr identified by K for the current connection."
-  (getf (slot-value *connection* 'connattrs) k))
+  (getf (slot-value connection 'connattrs) k))
 
-(defun (setf get-connattr) (v k)
-  (setf (getf (slot-value *connection* 'connattrs) k) v))
+(defun (setf get-connattr) (v k &optional (connection *connection*))
+  (setf (getf (slot-value connection 'connattrs) k) v))
 
 (defmacro with-connattrs ((&rest connattrs) &body forms)
   "Execute FORMS with connattrs replaced as specified by CONNATTRS, a plist."
diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp
index 72ed822..770d408 100644
--- a/src/connection/sbcl.lisp
+++ b/src/connection/sbcl.lisp
@@ -24,6 +24,9 @@
   (os:etypecase
     (debianlike (apt:installed "sbcl"))))
 
+(defparameter *sbcl* '("sbcl" "--noinform" "--noprint"
+                       "--disable-debugger" "--no-sysinit" "--no-userinit"))
+
 (defmethod establish-connection ((type (eql :sbcl)) remaining &key)
   (when (lisp-connection-p)
     (warn
@@ -32,24 +35,24 @@ Lisp. This can mean that prerequisite data gets extracted from encrypted
 stores and stored unencrypted under ~~/.cache, and as such is not
 recommended."))
   (ignoring-hostattrs (sbcl-available))
-  (request-lisp-systems)
-  (upload-all-prerequisite-data)
-  (inform t "Waiting for remote Lisp to exit, this may take some time ... ")
-  (force-output)
-  (multiple-value-bind (program forms)
-      (continue-deploy*-program remaining)
-    (multiple-value-bind (out err exit)
-        (run :may-fail :input program
-             "sbcl" "--noinform" "--noprint"
-             "--disable-debugger"
-             "--no-sysinit" "--no-userinit")
-      (inform t (if (zerop exit) "done." "failed.") :fresh-line nil)
-      (when-let ((lines (lines out)))
-        (inform t "  Output was:" :fresh-line nil)
-        (with-indented-inform (inform t lines)))
-      (unless (zerop exit)
-        ;; print FORMS not PROGRAM because latter might contain sudo passwords
-        (failed-change
-	 "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S"
-         err forms))))
+  (let ((requirements (asdf-requirements-for-host-and-features
+                       (safe-read-from-string
+                        (run :input "(prin1 *features*)" *sbcl*)
+                        :package :cl-user))))
+    (request-asdf-requirements requirements)
+    (upload-all-prerequisite-data)
+    (inform t "Waiting for remote Lisp to exit, this may take some time ... ")
+    (force-output)
+    (multiple-value-bind (program forms)
+        (continue-deploy*-program remaining requirements)
+      (multiple-value-bind (out err exit) (run :may-fail :input program *sbcl*)
+        (inform t (if (zerop exit) "done." "failed.") :fresh-line nil)
+        (when-let ((lines (lines out)))
+          (inform t "  Output was:" :fresh-line nil)
+          (with-indented-inform (inform t lines)))
+        (unless (zerop exit)
+          ;; print FORMS not PROGRAM because latter might contain sudo passwords
+          (failed-change
+	   "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S"
+           err forms)))))
   nil)
diff --git a/src/data.lisp b/src/data.lisp
index 868ac52..32c4d28 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -307,11 +307,13 @@ This is called by implementations of ESTABLISH-CONNECTION which call
 CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM."
   ;; Retrieving & keeping in memory refers to how %GET-DATA stores items of
   ;; string data in *STRING-DATA*.
+  (unless (get-connattr 'cached-data connection)
+    (setf (get-connattr 'cached-data connection)
+          (make-hash-table :test #'equal)))
   (flet ((record-cached-data (iden1 iden2 version)
            (let ((*connection* connection))
-             (push
-              (list iden1 iden2 (remote-data-pathname iden1 iden2 version))
-              (get-connattr 'cached-data)))))
+             (setf (gethash (cons iden1 iden2) (get-connattr 'cached-data))
+                   (remote-data-pathname iden1 iden2 version)))))
     (loop with *data-sources* = (cons (register-data-source :asdf)
                                       *data-sources*)
 
@@ -480,12 +482,97 @@ chance of those passwords showing up in the clear in the Lisp debugger."
 
 ;;;; Programs for remote Lisp images
 
-;; TODO unclear whether the need for sb-cltl2 require is a bug in trivial-macroexpand-all
-(defparameter continue-deploy*-program-implementation-specific
-  "#+sbcl (require \"sb-posix\") #+sbcl (require \"sb-cltl2\")")
-
-(defun continue-deploy*-program (remaining-connections)
-  "Return a program to complete the work of an enclosing call to DEPLOY*.
+(defclass asdf-requirements ()
+  ((asdf-requirements :type list :initform nil))
+  (:documentation
+   "A list of requirements as returned by certain calls to
+ASDF:REQUIRED-COMPONENTS.
+Elements are instances of ASDF:SYSTEM and/or ASDF:REQUIRE-SYSTEM."))
+
+(defun asdf-requirements-for-host-and-features (remote-lisp-features)
+  "Make an instance of ASDF-REQUIREMENTS for starting up a remote Lisp image in
+which *FEATURES* has the value of REMOTE-LISP-FEATURES, based on the Lisp
+systems required by the host currently being deployed.
+
+Called by connection types which start up remote Lisp images."
+  (let ((*features* remote-lisp-features)
+        (requirements (make-instance 'asdf-requirements)))
+    (with-slots (asdf-requirements) requirements
+      (dolist (system (propspec-systems (host-propspec *host*)))
+        (dolist (requirement
+                 ;; This call to ASDF:REQUIRED-COMPONENTS is based on one in
+                 ;; the definition of the ASDF:COMPONENT-DEPENDS-ON generic
+                 ;; for ((o gather-operation) (s system)).  We use
+                 ;; ASDF:COMPILE-OP as the :KEEP-OPERATION because
+                 ;; ASDF::BASIC-COMPILE-OP is not exported, so this won't work
+                 ;; for certain exotic systems.  See the comment in ASDF source.
+                 ;;
+                 ;; TODO Can we detect when this won't work and fail, possibly
+                 ;; falling back to ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP?
+                 (asdf:required-components
+                  (asdf:find-system system)
+                  :other-systems t :component-type 'asdf:system
+                  :keep-component 'asdf:system :goal-operation 'asdf:load-op
+                  :keep-operation 'asdf:compile-op))
+          ;; Handle UIOP specially because it comes with ASDF.
+          (unless (string= "uiop" (asdf:component-name requirement))
+            ;; What we really want instead of PUSHNEW here is a proper
+            ;; topological sort.
+            (pushnew requirement asdf-requirements))))
+      (nreversef asdf-requirements))
+    requirements))
+
+(defgeneric request-asdf-requirements (asdf-requirements)
+  (:documentation
+   "Request that all Lisp systems required to fulfill ASDF-REQUIREMENTS be
+uploaded to the remote cache of the currently established connection.
+
+Called by connection types which start up remote Lisp images.")
+  (:method ((asdf-requirements asdf-requirements))
+    (loop for requirement in (slot-value asdf-requirements 'asdf-requirements)
+          for type = (type-of requirement)
+          when (and (subtypep type 'asdf:system)
+                    (not (subtypep type 'asdf:require-system)))
+            do (require-data "--lisp-system"
+                             (asdf:component-name requirement)))))
+
+(defgeneric asdf-requirements-load-forms (asdf-requirements)
+  (:documentation
+   "Return forms to (compile and) load each of the Lisp systems specified in
+ASDF-REQUIREMENTS, after having uploaded those Lisp systems using
+UPLOAD-ALL-PREREQUISITE-DATA.")
+  (:method ((asdf-requirements asdf-requirements))
+    (loop with table = (get-connattr 'cached-data)
+          for requirement in (slot-value asdf-requirements 'asdf-requirements)
+          for name = (asdf:component-name requirement)
+          collect
+          (etypecase requirement
+            (asdf:require-system `(require ,name))
+            (asdf:system
+             (let ((source (gethash (cons "--lisp-system" name) table)))
+               (unless source
+                 (error "Somehow Lisp system ~A was not uploaded." name))
+               ;; TODO Using COMPILE-FILE-PATHNAME* like this has the
+               ;; advantage that, for example, SBCL will save the FASL
+               ;; somewhere from which only the same version of SBCL will try
+               ;; to load FASLs.  However, FASLs corresponding to old versions
+               ;; of Lisp systems are not cleaned up, and are not tiny files.
+               `(let ((fasl (compile-file-pathname* ,source)))
+                  (if (file-exists-p fasl)
+                      (load fasl)
+                      ;; The concatenated source of at least Alexandria won't
+                      ;; compile unless it's loaded first.  This means we
+                      ;; compile every library that's changed since the last
+                      ;; deploy twice, which is not ideal.  One possible
+                      ;; improvement would be to maintain a list of systems
+                      ;; known not to have this problem, such as
+                      ;; Consfigurator, and switch the order of the LOAD and
+                      ;; COMPILE-FILE* here for those.
+                      (progn (load ,source) (compile-file* ,source))))))))))
+
+(defgeneric continue-deploy*-program (remaining-connections asdf-requirements)
+  (:documentation
+   "Return a program to complete the work of an enclosing call to DEPLOY*.
 
 Implementations of ESTABLISH-CONNECTION which start up remote Lisp images call
 this function, instead of CONTINUE-DEPLOY*, and use the result to instruct the
@@ -497,79 +584,70 @@ host which will run the Lisp image must already be established.
 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.
+achieved by sending the return value of this function into a REPL's stdin.")
+  (:method (remaining-connections (asdf-requirements asdf-requirements))
+    (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)
-           ;; We used to bind a handler here to invoke SKIP-DATA-SOURCES upon
-           ;; MISSING-DATA-SOURCE, which means that remote Lisp images were
-           ;; allowed to try querying data sources.  Now we just bind
-           ;; *NO-DATA-SOURCES* to t here.  While some data sources make sense
-           ;; in remote Lisp images, others might make arbitrary network
-           ;; connections or read out of other users' homedirs (e.g. if you
-           ;; are using (:SUDO :SBCL), the remote Lisp might try to read your
-           ;; ~/.gnupg, or on another host, someone else's ~/.gnupg who has
-           ;; the same username as you), which are usually undesirable.  So at
-           ;; least until some cool use case comes along, just require all
-           ;; data source queries to occur in the root Lisp.
-           `(let ((*no-data-sources* t)
-                  (*consfigurator-debug-level* ,*consfigurator-debug-level*))
-              ,@forms)))
-    (let* ((intern-forms
-             (loop for (export . name)
-                     in '((nil . "*NO-DATA-SOURCES*")
-                          (t . "*CONSFIGURATOR-DEBUG-LEVEL*"))
-                   for intern-form
-                     = `(intern ,name (find-package "CONSFIGURATOR"))
-                   if export collect
-                     `(export ,intern-form (find-package "CONSFIGURATOR"))
-                   else collect intern-form))
-	   (proclamations `((proclaim '(special *no-data-sources*))
-                            (proclaim '(special *consfigurator-debug-level*))))
-           (load-forms
-             (loop for system in (propspec-systems (host-propspec *host*))
-                   collect `(load
-                             ,(caddar
-                               (remove-if-not
-                                (lambda (d)
-                                  (string= (car d) "--lisp-system")
-                                  (string= (cadr d) (normalise-system system)))
-                                (get-connattr 'cached-data))))))
-           (forms `((make-package "CONSFIGURATOR")
-                    ,@intern-forms
-		    ,@proclamations
-                    ;; (define-condition missing-data-source (error) ())
-                    (require "asdf")
-		    ;; Hide the LOAD output unless loading failed, because
-		    ;; there will be a lot of spurious warnings due to not
-		    ;; compiling.
-		    (let ((string (make-array '(0)
-					      :element-type 'character
-					      :fill-pointer 0 :adjustable t)))
-		      (handler-case
-			  (with-output-to-string (stream string)
-			    (let ((*error-output* stream)
-				  (*standard-output* stream))
-			      ,(wrap load-forms)))
-			(serious-condition (c)
-			  (format *error-output* "~&Failed to LOAD:~%~A" c)
-			  (uiop:quit 2))))
-                    ,(wrap `((%consfigure ',remaining-connections ,*host*))))))
-      (handler-case
-          (with-standard-io-syntax
-            (let ((*allow-printing-passphrases* t))
-              ;; need line breaks in between so that packages exist before we
-              ;; try to have remote Lisp read sexps containing symbols from
-              ;; those packages
-              (values
-               (format nil "~A~%~{~A~^~%~}"
-                       continue-deploy*-program-implementation-specific
-                       (mapcar #'prin1-to-string forms))
-               forms)))
-        (print-not-readable (c)
-          (error "The Lisp printer could not serialise ~A for
+    (flet ((wrap (forms)
+             ;; We used to bind a handler here to invoke SKIP-DATA-SOURCES
+             ;; upon MISSING-DATA-SOURCE, which means that remote Lisp images
+             ;; were allowed to try querying data sources.  Now we just bind
+             ;; *NO-DATA-SOURCES* to t here.  While some data sources make
+             ;; sense in remote Lisp images, others might make arbitrary
+             ;; network connections or read out of other users' homedirs
+             ;; (e.g. if you are using (:SUDO :SBCL), the remote Lisp might
+             ;; try to read your ~/.gnupg, or on another host, someone else's
+             ;; ~/.gnupg who has the same username as you), which are usually
+             ;; undesirable.  So at least until some cool use case comes
+             ;; along, just require all data source queries to occur in the
+             ;; root Lisp.
+             `(let ((*no-data-sources* t)
+                    (*consfigurator-debug-level* ,*consfigurator-debug-level*))
+                ,@forms)))
+      (let* ((intern-forms
+               (loop for (export . name)
+                       in '((nil . "*NO-DATA-SOURCES*")
+                            (t . "*CONSFIGURATOR-DEBUG-LEVEL*"))
+                     for intern-form
+                       = `(intern ,name (find-package "CONSFIGURATOR"))
+                     if export collect
+                       `(export ,intern-form (find-package "CONSFIGURATOR"))
+                     else collect intern-form))
+             (proclamations `((proclaim '(special *no-data-sources*))
+                              (proclaim '(special *consfigurator-debug-level*))))
+             (forms `((make-package "CONSFIGURATOR")
+                      ,@intern-forms
+                      ,@proclamations
+                      ;; (define-condition missing-data-source (error) ())
+                      (require "asdf")
+                      ;; Hide the compile and/or load output unless there are
+                      ;; failures, as it's verbose and rarely of interest.
+                      (let ((string (make-array '(0)
+                                                :element-type 'character
+                                                :fill-pointer 0 :adjustable t)))
+                        (handler-case
+                            (with-output-to-string (stream string)
+                              (let ((*error-output* stream)
+                                    (*standard-output* stream))
+                                ,(wrap (asdf-requirements-load-forms asdf-requirements))))
+                          (serious-condition (c)
+                            (format *error-output*
+                                    "~&Failed to compile and/or load:~%~A" c)
+                            (uiop:quit 2))))
+                      ,(wrap `((%consfigure ',remaining-connections ,*host*))))))
+        (handler-case
+            (with-standard-io-syntax
+              (let ((*allow-printing-passphrases* t))
+                ;; need line breaks in between so that packages exist before we
+                ;; try to have remote Lisp read sexps containing symbols from
+                ;; those packages
+                (values
+                 (format nil "~{~A~^~%~}" (mapcar #'prin1-to-string forms))
+                 forms)))
+          (print-not-readable (c)
+            (error "The Lisp printer could not serialise ~A for
 transmission to the remote Lisp.
 
 This is probably because your property application specification and/or static
@@ -581,12 +659,4 @@ hostattrs; see \"Pitfalls\" in the Consfigurator user manual.
 If ~:*~A is a simple object then you may be able to resolve this by defining
 a PRINT-OBJECT method for your class, possibly using
 CONSFIGURATOR:DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE."
-                 (print-not-readable-object c)))))))
-
-(defun request-lisp-systems ()
-  "Request that all Lisp systems required by the host currently being deployed
-are uploaded to the remote cache of the currently established connection.
-
-Called by connections which start up remote Lisp images."
-  (dolist (system (propspec-systems (host-propspec *host*)))
-    (push-hostattrs :data (cons "--lisp-system" (normalise-system system)))))
+                   (print-not-readable-object c))))))))
diff --git a/src/data/asdf.lisp b/src/data/asdf.lisp
index 5db7c7a..a681bb1 100644
--- a/src/data/asdf.lisp
+++ b/src/data/asdf.lisp
@@ -18,33 +18,27 @@
 (in-package :consfigurator.data.asdf)
 (named-readtables:in-readtable :consfigurator)
 
-;; could we have both :asdf-monolithic and :asdf-something_else where in the
-;; latter we filter out the names of systems already known to be available on
-;; the remote side, so those don't need to be uploaded?  for example, the
-;; :sbcl connection type can try to install them with apt on the remote side,
-;; then ask asdf for a concatenated source for everything excluding those.  if
-;; asdf can't be asked to do that, maybe we can ask it to produce one file per
-;; system, and then we eliminate those we don't want and concatenate the
-;; result ourselves.  maybe we can create a fake system object based on the
-;; real one, remove some deps from it according to a known mapping of systems
-;; to Debian package names, then ask asdf to concatenate that system
-
 (defmethod register-data-source ((type (eql :asdf)) &key)
   (cons #'asdf-data-source-check #'get-path-to-concatenated-system))
 
 (defun asdf-data-source-check (iden1 system)
-  (when (and (string= iden1 "--lisp-system")
-             (asdf:find-system system nil))
-    (get-universal-time)))
+  (let ((system (and (string= iden1 "--lisp-system")
+                     (asdf:find-system system nil))))
+    (and system (system-version system))))
 
 (defun get-path-to-concatenated-system (iden1 system)
   "Try to concatenate all the source code for SYSTEM, store it somewhere and
 return the filename."
-  (let ((op 'asdf:monolithic-concatenate-source-op)
+  (let ((op 'asdf:concatenate-source-op)
         (co (asdf:find-component system nil)))
     (asdf:operate op co)
     (make-instance 'file-data :file (asdf:output-file op co)
                               :mime "text/plain"
                               :iden1 iden1
                               :iden2 system
-                              :version (get-universal-time))))
+                              :version (system-version co))))
+
+(defun system-version (system)
+  (reduce #'max
+          (mapcar #'file-write-date
+                  (asdf:input-files 'asdf:concatenate-source-op system))))
diff --git a/src/package.lisp b/src/package.lisp
index bc4a146..a0a5f9f 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -27,7 +27,10 @@
                           #:file-exists-p
 			  #:directory-exists-p
                           #:with-current-directory
-			  #:delete-directory-tree)
+			  #:delete-directory-tree
+                          #:safe-read-from-string
+                          #:compile-file*
+                          #:compile-file-pathname*)
   (:export ;; re-export from UIOP
            #:strcat
            #:string-prefix-p
@@ -53,6 +56,9 @@
 	   #:directory-exists-p
            #:with-current-directory
 	   #:delete-directory-tree
+           #:safe-read-from-string
+           #:compile-file*
+           #:compile-file-pathname*
 
            ;; util.lisp
            #:lines
@@ -234,10 +240,11 @@
            #:connection-upload
            #:connection-clear-data-cache
            #:upload-all-prerequisite-data
-           #:request-lisp-systems
            #:passphrase
            #:make-passphrase
            #:get-data-protected-string
+           #:asdf-requirements-for-host-and-features
+           #:request-asdf-requirements
            #:continue-deploy*-program))
 
 (defpackage :consfigurator.property.cmd
diff --git a/src/util.lisp b/src/util.lisp
index 60653da..c8dc04c 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -33,12 +33,6 @@
   `(and (symbolp ,symbol)
         (string= (symbol-name ',name) (symbol-name ,symbol))))
 
-(defun normalise-system (system)
-  (etypecase system
-    (string system)
-    (symbol (string-downcase
-             (symbol-name system)))))
-
 (defun memstring= (string list)
   (member string list :test #'string=))