diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-23 17:01:49 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-23 17:01:49 -0700 |
commit | bf304f4c287f0a4501be6c0d4680c403a43735fd (patch) | |
tree | 3290710ae52fea2ac3450b28f4c8cc7673daf560 | |
parent | f190406af14bebb93e4632b57dae5ed675539d35 (diff) | |
download | consfigurator-bf304f4c287f0a4501be6c0d4680c403a43735fd.tar.gz |
implement the basic functionaltiy of :DEBIAN-SBCL connection type
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r-- | src/connection/debian-sbcl.lisp | 15 | ||||
-rw-r--r-- | src/data.lisp | 58 | ||||
-rw-r--r-- | src/deployment.lisp | 5 | ||||
-rw-r--r-- | src/package.lisp | 5 | ||||
-rw-r--r-- | src/util.lisp | 5 |
5 files changed, 57 insertions, 31 deletions
diff --git a/src/connection/debian-sbcl.lisp b/src/connection/debian-sbcl.lisp index 0c3edaa..56c4d8e 100644 --- a/src/connection/debian-sbcl.lisp +++ b/src/connection/debian-sbcl.lisp @@ -21,13 +21,10 @@ (run "which sbcl >/dev/null 2>&1 || apt-get -y install sbcl") (request-lisp-systems) (upload-all-prerequisite-data) - (let ((program - `(handler-bind ((consfigurator:missing-data-source - #'consfigurator:skip-data-source)) - ,@(load-forms-for-remote-cached-lisp-systems) - ,(deploy*-form-for-remote-lisp remaining)))) - (print (run :input (prin1-to-string program) - "sbcl" "--noinform" "--noprint" - "--disable-debugger" - "--no-sysinit" "--no-user-init"))) + (princ "Handing over to remote Lisp ...") + (format t "~{ ~A~%~}" + (runlines :input (deployment-handover-program remaining) + "sbcl" "--noinform" "--noprint" + "--disable-debugger" + "--no-sysinit" "--no-user-init")) nil) diff --git a/src/data.lisp b/src/data.lisp index 8825535..368a6c6 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -279,7 +279,9 @@ appropriate. Falls back to CONNECTION-WRITEFILE." (data-version data)))) (declare (special *dest*)) (run "mkdir" "-p" (pathname-directory-pathname *dest*)) - (call-next-method))) + (call-next-method) + (push (list (iden1 data) (iden2 data) *dest*) + (getf *this-hop-info* :cached-data)))) (defmethod connection-upload-data ((data file-data)) (declare (special *dest*)) @@ -340,15 +342,47 @@ of the current connection, where each entry is of the form (runlines :may-fail "find" (get-remote-data-cache-dir) "-type" "f" "-printf" "%P\\n"))) -;; bit of a layering violation but better than exposing REMOTE-DATA-PATHNAME -(defun load-forms-for-remote-cached-lisp-systems () - "Return forms calling LOAD for concatenated, remote-cached copies of each of -the Lisp systems required by *HOST*'s propspec. +(defun deployment-handover-program (remaining) + "Return a program which instructs a remote Lisp image to continue DEPLOY*. -Only to be called by implementations of ESTABLISH-CONNECTION, after calling -UPLOAD-ALL-PREREQUISITE-DATA." - (loop for system in (slot-value (slot-value *host* 'propspec) 'systems) - collect `(load ,(remote-data-pathname "--lisp-system" system)))) +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. + +Called by connections which start up remote Lisp images." + (flet ((wrap (forms) + `(handler-bind ((missing-data-source + (lambda (c) + (declare (ignore c)) + (invoke-restart 'skip-data-source)))) + ,@forms))) + (let ((intern-forms + (loop for name in '("MISSING-DATA-SOURCE" "SKIP-DATA-SOURCE") + collect + `(export (intern ,name (find-package "CONSFIGURATOR")) + (find-package "CONSFIGURATOR")))) + (load-forms + (loop for system + in (slot-value (slot-value *host* 'propspec) 'systems) + collect `(load + ,(caddar + (remove-if-not + (lambda (d) + (string= (car d) "--lisp-system") + (string= (cadr d) (normalise-system system))) + (getf *this-hop-info* :cached-data)))))) + (*package* (find-package "COMMON-LISP-USER"))) + ;; need line breaks in between so that packages exist before we try to + ;; have remote Lisp read sexps containing symbols from those packages + (format nil "~{~A~^~%~}" + (mapcar + #'prin1-to-string + `((make-package "CONSFIGURATOR") + ,@intern-forms + (define-condition missing-data-source (error) ()) + (require "asdf") + (let ((*standard-output* *error-output*)) + ,(wrap load-forms)) + ,(wrap `((deploy* ,(or remaining :local) ,*host*))))))))) (defun request-lisp-systems () "Request that all Lisp systems required by the host currently being deployed @@ -356,8 +390,4 @@ are uploaded to the remote cache of the currently established connection. Called by connections which start up remote Lisp images." (dolist (system (slot-value (slot-value *host* 'propspec) 'systems)) - (push-hostattrs :data (cons "--lisp-system" - (etypecase system - (string system) - (symbol (string-downcase - (symbol-name system)))))))) + (push-hostattrs :data (cons "--lisp-system" (normalise-system system))))) diff --git a/src/deployment.lisp b/src/deployment.lisp index 1d15217..e856b38 100644 --- a/src/deployment.lisp +++ b/src/deployment.lisp @@ -48,11 +48,6 @@ For example, if you usually deploy properties to athena by SSH, and then you can eval (athena.silentflame.com) to apply athena's properties." `(defdeploy ,host-name (,connection ,host-name))) -;; this exists just to avoid exposing *HOST* but otherwise it's not really a -;; nice abstraction -(defun deploy*-form-for-remote-lisp (remaining) - `(deploy* ,(or remaining :local) *host*)) - (defmacro deploy (connection host &body additional-properties) "Establish a connection of type CONNECTION to HOST, and apply each of the host's usual properties, followed by specified by ADDITIONAL-PROPERTIES, an diff --git a/src/package.lisp b/src/package.lisp index e6ead39..8808516 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -99,7 +99,6 @@ #:deploy-these #:deploys #:deploys-these - #:deploy*-form-for-remote-lisp #:*last-hop-info #:*this-hop-info* @@ -123,8 +122,8 @@ #:with-data-stream #:get-data-string #:upload-all-prerequisite-data - #:load-forms-for-remote-cached-lisp-systems - #:request-lisp-systems)) + #:request-lisp-systems + #:deployment-handover-program)) (defpackage :consfigurator.connection.ssh (:use #:cl #:consfigurator #:alexandria)) diff --git a/src/util.lisp b/src/util.lisp index 9c6c4ec..64d049f 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -32,6 +32,11 @@ `(and (symbolp ,symbol) (string= (symbol-name ',name) (symbol-name ,symbol)))) +(defun normalise-system (system) + (etypecase system + (string system) + (symbol (string-downcase + (symbol-name system))))) ;;;; Version numbers |