implement the basic functionaltiy of :DEBIAN-SBCL connection type

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

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