move remote Lisp images part of data.lisp to its own file

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

1 files changed, 0 insertions, 231 deletions

diff --git a/src/data.lisp b/src/data.lisp
index cbcc138..d09e4e2 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -508,234 +508,3 @@ chance of those passwords showing up in the clear in the Lisp debugger."
       (print-unreadable-object (passphrase stream)
         (format stream "PASSPHRASE")))
   passphrase)
-
-
-;;;; Programs for 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))))))))