diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-28 16:10:59 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-28 16:10:59 -0700 |
commit | cb71af7012147cb639d080af231bc0025e31f7b1 (patch) | |
tree | bd1e540e6f39036591c8c73535f863266922234d | |
parent | a35683bf169d810e22be75bce3b0971b93180c45 (diff) | |
download | consfigurator-cb71af7012147cb639d080af231bc0025e31f7b1.tar.gz |
tidy up entering and reentering Consfigurator's primary loop
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r-- | src/connection.lisp | 10 | ||||
-rw-r--r-- | src/connection/chroot/fork.lisp | 12 | ||||
-rw-r--r-- | src/connection/debian-sbcl.lisp | 2 | ||||
-rw-r--r-- | src/data.lisp | 19 | ||||
-rw-r--r-- | src/deployment.lisp | 28 | ||||
-rw-r--r-- | src/package.lisp | 4 |
6 files changed, 53 insertions, 22 deletions
diff --git a/src/connection.lisp b/src/connection.lisp index 0ba08a6..6efce31 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -32,13 +32,11 @@ global value should be regarded as a constant.") (:documentation "Within the context of the current connection, connect to HOST by establishing a new connection of type TYPE. -Either starts a Lisp image somewhere else, tells it to continue establishing -REMAINING (by telling it to call DEPLOY* with arguments obtained by (locally) -evaluating (list (or REMAINING '(:local)) *host*)), and returns nil, or -returns a object suitable to be the value of *CONNECTION*. +Either returns an object suitable to be the value of *CONNECTION*, or calls +either CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM and returns nil. -Any implementation which hands over to a remote Lisp image will need to -upload any prerequisite data required by the deployment.")) +Any implementation which calls CONTINUE-DEPLOY*-PROGRAM will need to call +UPLOAD-ALL-PREREQUISITE-DATA.")) (defgeneric preprocess-connection-args (type &key) (:documentation diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp index 5fe3711..bea6b10 100644 --- a/src/connection/chroot/fork.lisp +++ b/src/connection/chroot/fork.lisp @@ -52,12 +52,12 @@ (list *standard-input* *debug-io* *terminal-io*)) (unless (zerop (chroot into)) (error "chroot(2) failed; are you root?")) - ;; note that we can't just - ;; (return-from establish-connection (establish-connection :local) - ;; because we need to kill off the child afterwards, rather than - ;; returning to the child's REPL or whatever else - ;; TODO public interface to DEPLOY* or similar needed here - (consfigurator::deploy* (or remaining :local) consfigurator::*host*) + ;; it would be nice to reenter Consfigurator's primary loop by + ;; just calling (return-from establish-connection + ;; (establish-connection :local)) here, but we need to kill off + ;; the child afterwards, rather than returning to the child's + ;; REPL or whatever else + (continue-deploy* remaining) (uiop:quit 0)) (serious-condition (c) (format *error-output* ":CHROOT.FORK child failed: ~A~%" c) diff --git a/src/connection/debian-sbcl.lisp b/src/connection/debian-sbcl.lisp index 5965853..208655e 100644 --- a/src/connection/debian-sbcl.lisp +++ b/src/connection/debian-sbcl.lisp @@ -23,7 +23,7 @@ (upload-all-prerequisite-data) (princ "Waiting for remote Lisp to exit, this may take some time ... ") (force-output) - (let ((program (deployment-handover-program remaining))) + (let ((program (continue-deploy*-program remaining))) (multiple-value-bind (out err exit) (run :may-fail :input program "sbcl" "--noinform" "--noprint" diff --git a/src/data.lisp b/src/data.lisp index c6e5246..63d5e2d 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -345,17 +345,27 @@ of the current connection, where each entry is of the form "-type" "f" "-printf" "%P\\n") (and (zerop exit) (lines out))))) +;; we can't just default REMAINING to :LOCAL in the lambda list because it is +;; legitimate for callers to explicitly pass nil. +;; ;; TODO on remote side, catch read errors and signal our own which says ;; something more specific -- "This has probably been caused by an attempt to ;; use a property application specification or set of static informational ;; attributes which cannot be serialised by the Lisp printer" -(defun deployment-handover-program (remaining) - "Return a program which instructs a remote Lisp image to continue DEPLOY*. +(defun continue-deploy*-program (remaining-connections) + "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. -Called by connections which start up remote Lisp images." +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." (flet ((wrap (forms) `(handler-bind (;; we can skip missing data sources because these are not @@ -402,7 +412,8 @@ Called by connections which start up remote Lisp images." (require "asdf") (let ((*standard-output* *error-output*)) ,(wrap load-forms)) - ,(wrap `((deploy* ',(or remaining :local) ,*host*))))))))) + ,(wrap `((deploy* ',(or remaining-connections :local) + ,*host*))))))))) (defun request-lisp-systems () "Request that all Lisp systems required by the host currently being deployed diff --git a/src/deployment.lisp b/src/deployment.lisp index 395cec8..4aef20f 100644 --- a/src/deployment.lisp +++ b/src/deployment.lisp @@ -108,9 +108,20 @@ DEFHOST forms can override earlier entries (see DEFHOST's docstring)." (eval-propspec-hostattrs ,propspec)) (deploy* ',connection ,new-host)))) -;; this is the main do-work loop for Consfigurator; remote Lisp images are -;; instructed to pick up the remaining work of this loop (defun deploy* (connections host) + "Execute the deployment which is defined by the pair (CONNECTIONS . HOST). + +This is the entry point to Consfigurator's primary loop. Typically users use +DEPLOY, DEPLOY-THESE, and the function definitions established by DEFDEPLOY, +DEFDEPLOY-THESE, etc., rather than calling this function. However, code which +programmatically constructs deployments will need to call this function. + +Unlike DEPLOY there is no argument to supply additional properties, and there +is no function DEPLOY-THESE*. This is because merging/replacing properties +into HOST's propspec cannot be done without either the implicit context +established by a consfig (specifically, by IN-CONSFIG) or with an explicit +specification of the SYSTEMS slot of the resultant property application +specification." ;; make a partial own-copy of HOST so that connections can add new pieces of ;; required prerequisite data; specifically, so that they can request the ;; source code of ASDF systems @@ -120,8 +131,8 @@ DEFHOST forms can override earlier entries (see DEFHOST's docstring)." (labels ((connect (connections) (destructuring-bind ((type . args) . remaining) connections - ;; implementations of ESTABLISH-CONNECTION return nil if they - ;; have handed off to a remote Lisp image + ;; implementations of ESTABLISH-CONNECTION which call + ;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM return nil to us (when-let ((*connection* (apply #'establish-connection type remaining args))) (if remaining @@ -132,6 +143,15 @@ DEFHOST forms can override earlier entries (see DEFHOST's docstring)." collect (apply #'preprocess-connection-args (ensure-cons connection))))))) +;; we can't just default CONNECTIONS to :LOCAL in the lambda list, because it +;; is legitimate for callers to explicitly pass nil +(defun continue-deploy* (remaining-connections) + "Complete the work of an enclosing call to DEPLOY*. + +Used by implementations of ESTABLISH-CONNECTION which need to do something like +fork(2) and then return to Consfigurator's primary loop in the child." + (deploy* (or remaining-connections :local) *host*)) + ;; these might need to be special-cased in parsing propspecs, because we ;; probably want it to be easy for the user to pass unevaluated propspecs to ;; these, but we want the evaluation to happen in the root Lisp. diff --git a/src/package.lisp b/src/package.lisp index 6aab491..5d32573 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -103,6 +103,8 @@ #:deploy-these #:deploys #:deploys-these + #:deploy* + #:continue-deploy* ;; data.lisp #:data @@ -125,7 +127,7 @@ #:get-data-string #:upload-all-prerequisite-data #:request-lisp-systems - #:deployment-handover-program)) + #:continue-deploy*-program)) (defpackage :consfigurator.connection.shell-wrap (:use #:cl #:consfigurator) |