attempt to implement :DEBIAN-SBCL connection type

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

4 files changed, 36 insertions, 34 deletions

diff --git a/src/connection/debian-sbcl.lisp b/src/connection/debian-sbcl.lisp
index 7befb47..4ce2623 100644
--- a/src/connection/debian-sbcl.lisp
+++ b/src/connection/debian-sbcl.lisp
@@ -17,38 +17,17 @@
 
 (in-package :consfigurator.connection.debian-sbcl)
 
-
-;; (handler-bind ((consfigurator:missing-data-source
-;;                 #'consfigurator:skip-data-source))
-;;   ...)
-
-
 (defmethod establish-connection ((type (eql :debian-sbcl)) remaining &key)
-  ;; any connection type which starts up a Lisp connection is going to want to
-  ;; do something like what this loop does, so just make it a core function?
-  ;; (loop for system in (slot-value (slot-value *host* :hostattrs) :systems)
-  ;; 	do (push (cons "--lisp-system" system) (getf *host* :data)))
-
-  (unless (= 0 (nth-value 1 (run "which" "sbcl" "2>/dev/null"
-				 "||" "apt-get" "-y" "install" "sbcl")))
-    (error "Could not get sbcl installed on the remote host"))
+  (run "which" "sbcl" ">/dev/null" "2>&1" "||" "apt-get" "-y" "install" "sbcl")
+  (request-lisp-systems)
   (upload-all-prerequisite-data)
-
-  ;; I think we want a function in data.lisp which returns a LOAD form which
-  ;; will load a given lisp system out of a local cache.  After calling
-  ;; upload-all-prerequisite-data we can call that from here to get a form
-  ;; suitable for feeding to remote sbcl.  Slight layering violation, and only
-  ;; to be called by connections, not properties.  But better than exposing
-  ;; get-remote-data-cache-dir.
-
-  ;; PROGRAM is (load "~/.cache/...") (deploy :local host properties)
-  ;; (multiple-value-bind ()
-  ;;     (run :input program "sbcl"
-  ;; 	   "--noinform"
-  ;; 	   "--noprint"
-  ;; 	   "--disable-debugger"
-  ;; 	   "--no-sysinit"
-  ;; 	   "--no-user-init"))
-  ;; relay its output and signal something if it exits nonzero
-
-  )
+  (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")))
+  nil)
diff --git a/src/data.lisp b/src/data.lisp
index 5cab36f..cdc9d5a 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -323,3 +323,18 @@ 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.
+
+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))))
+
+;; connections which start up remote Lisp images use this
+(defun request-lisp-systems ()
+  (dolist (system (slot-value (slot-value *host* 'propspec) 'systems))
+    (push-hostattrs :data (cons "--lisp-system" system))))
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 91f14f0..3e6caad 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -55,6 +55,11 @@ Deployments bind this variable.  Its global value should remain nil.
 The main point of this is to allow properties to access the context in which
 they're being applied.")
 
+;; 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 298fdbe..17453db 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -99,6 +99,7 @@
 	   #:deploy-these
 	   #:deploys
 	   #:deploys-these
+	   #:deploy*-form-for-remote-lisp
 
 	   ;; data.lisp
 	   #:data
@@ -119,7 +120,9 @@
 	   #:get-data-stream
 	   #:with-data-stream
 	   #:get-data-string
-	   #:upload-all-prerequisite-data))
+	   #:upload-all-prerequisite-data
+	   #:load-forms-for-remote-cached-lisp-systems
+	   #:request-lisp-systems))
 
 (defpackage :consfigurator.connection.ssh
   (:use #:cl #:consfigurator #:alexandria))