From b2fbc36eedd14e0eb6c012554810a5b75a2e015a Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 17 May 2021 14:18:39 -0700 Subject: 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 --- src/connection.lisp | 8 +- src/connection/sbcl.lisp | 43 ++++---- src/data.lisp | 248 ++++++++++++++++++++++++++++++----------------- src/data/asdf.lisp | 26 ++--- src/package.lisp | 11 ++- src/util.lisp | 6 -- 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=)) -- cgit v1.2.3