From 8d6413e98de0390b2541edc46ed2482e6fef60da Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 18 Jul 2021 15:53:46 -0700 Subject: move remote Lisp images part of data.lisp to its own file Signed-off-by: Sean Whitton --- src/image.lisp | 249 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 249 insertions(+) create mode 100644 src/image.lisp (limited to 'src/image.lisp') diff --git a/src/image.lisp b/src/image.lisp new file mode 100644 index 0000000..b7e6225 --- /dev/null +++ b/src/image.lisp @@ -0,0 +1,249 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2021 Sean Whitton + +;;; This file is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3, or (at your option) +;;; any later version. + +;;; This file is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. + +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . + +(in-package :consfigurator) +(named-readtables:in-readtable :consfigurator) + +;;;; Remote Lisp images + +(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-form (asdf-requirements) + (:documentation + "Return form 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)) + ;; As soon as we recompile something, we have to recompile everything else + ;; following it in the list, because macro definitions may have changed. + `(let* (recompile + (file (merge-pathnames "consfigurator/fasls" + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache"))))) + (record (with-open-file (stream file :if-does-not-exist nil) + (and stream (safe-read-from-string + (slurp-stream-string stream)))))) + (unwind-protect + (progn + ,@(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)) + ;; 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. + `(let ((fasl (compile-file-pathname* ,source))) + (if (and (file-exists-p fasl) (not recompile)) + (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. + (let ((pair (assoc ,source record))) + (load ,source) + (or (compile-file* ,source) + (error "Failed to compile ~S" ,source)) + (if pair + (rplacd pair fasl) + (setq record (acons ,source fasl record))) + (setq recompile t))))))))) + (with-open-file (stream file :direction :output :if-exists :supersede) + (with-standard-io-syntax + (prin1 record stream))))))) + +(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 +newly started image. + +Will query the remote cache for paths to Lisp systems, so a connection to the +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.") + (: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 (form) + ;; 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*)) + ,form))) + (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 or the debug level is at least 3, as it's verbose + ;; and not usually of interest. + ,(wrap + `(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)) + ,(asdf-requirements-load-form + asdf-requirements))) + (serious-condition (c) + (format + *error-output* + "~&Failed to compile and/or load:~%~A~&~%Compile and/or load output:~%~%~A" + c string) + (uiop:quit 2))) + (when (>= *consfigurator-debug-level* 3) + (format t "~&~A" string)))) + ;; Delete old FASLs. With SBCL they are megabytes in size. + (with-lisp-data-file + (record (merge-pathnames + "consfigurator/fasls" + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache"))))) + (loop for cell in record + if (file-exists-p (car cell)) + collect cell into accum + else do (ignore-errors (delete-file (cdr cell))) + finally (setq record accum))) + ;; Continue the deployment. + ,(wrap + `(with-backtrace-and-exit-code + (%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 +informational attributes contain values which the Lisp printer does not know +how to print. If ~:*~A is something like a function object then you need to +rework your deployment so that it does not end up in the propspec or +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)))))))) -- cgit v1.2.3