diff options
| -rw-r--r-- | src/connection.lisp | 16 | ||||
| -rw-r--r-- | src/connection/chroot/fork.lisp | 2 | ||||
| -rw-r--r-- | src/connection/chroot/shell.lisp | 2 | ||||
| -rw-r--r-- | src/connection/debian-sbcl.lisp | 2 | ||||
| -rw-r--r-- | src/connection/ssh.lisp | 2 | ||||
| -rw-r--r-- | src/connection/sudo.lisp | 2 | ||||
| -rw-r--r-- | src/data.lisp | 10 | ||||
| -rw-r--r-- | src/package.lisp | 5 | ||||
| -rw-r--r-- | src/property/apt.lisp | 6 | ||||
| -rw-r--r-- | src/propspec.lisp | 7 | ||||
| -rw-r--r-- | src/util.lisp | 45 |
11 files changed, 77 insertions, 22 deletions
diff --git a/src/connection.lisp b/src/connection.lisp index d1c87e2..4b86b04 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -217,12 +217,12 @@ which will be cleaned up when BODY is finished." :exit-code exit)))))) (defmacro %process-run-args (&body forms) - `(let (cmd input may-fail for-exit env princ) + `(let (cmd input may-fail for-exit env inform) (loop for arg = (pop args) do (case arg - (:for-exit (setq may-fail t for-exit t)) - (:may-fail (setq may-fail t)) - (:princ (setq princ t)) + (:for-exit (setq may-fail t for-exit t)) + (:may-fail (setq may-fail t)) + (:inform (setq inform t)) (:input (setq input (pop args))) (:env (setq env (pop args))) (t (mapc (lambda (e) @@ -265,7 +265,7 @@ Keyword arguments accepted: does not exit nonzero, usually because it is being called partly or only for its exit code - - :PRINC -- send a copy of the output to *STANDARD-OUTPUT* + - :INFORM -- send a copy of the output to *STANDARD-OUTPUT* - :INPUT INPUT -- pass the content of the string or stream INPUT on stdin @@ -278,10 +278,11 @@ case return only the exit code." (%process-run-args (with-remote-temporary-file (stdout) (setq cmd (format nil "( ~A ) >~A" cmd stdout)) + (informat 3 "RUN ~A" cmd) (multiple-value-bind (err exit) (connection-run *connection* cmd input) (let ((out (readfile stdout))) - (when princ (format t "~{ ~A~%~}" (lines out))) + (when inform (informat 1 "~{ ~A~%~}" (lines out))) (if (or may-fail (= exit 0)) (if for-exit exit (values out err exit)) (error 'run-failed @@ -300,9 +301,10 @@ Some :POSIX properties which want to run a lot of commands and don't need to separate the streams might want to use this too, but usually it is best to start with RUN." (%process-run-args + (informat 3 "MRUN ~A" cmd) (multiple-value-bind (out exit) (connection-run *connection* cmd input) - (when princ (format t "~{ ~A~%~}" (lines out))) + (when inform (informat 1 "~{ ~A~%~}" (lines out))) (if (or may-fail (= exit 0)) (if for-exit exit (values out exit)) (error 'run-failed diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp index 4969539..d522304 100644 --- a/src/connection/chroot/fork.lisp +++ b/src/connection/chroot/fork.lisp @@ -39,7 +39,7 @@ (unless (lisp-connection-p) (error "Forking into a chroot requires a Lisp-type connection")) #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") - (format t "Forking into chroot at ~A~%" into) + (informat 1 "~&Forking into chroot at ~A" into) ;; TODO copy required prerequisite data into the chroot -- propellor uses a ;; bind mount but we might be the root Lisp, in which case we don't have a ;; cache to bind mount in. use chroot.shell connection to upload? diff --git a/src/connection/chroot/shell.lisp b/src/connection/chroot/shell.lisp index 66b2845..5ed87fc 100644 --- a/src/connection/chroot/shell.lisp +++ b/src/connection/chroot/shell.lisp @@ -20,7 +20,7 @@ (defmethod establish-connection ((type (eql :chroot.shell)) remaining &key into) (declare (ignore remaining)) - (format t "Shelling into chroot at ~A~%" into) + (informat 1 "~&Shelling into chroot at ~A" into) (make-instance 'shell-chroot-connection :root into)) (defclass shell-chroot-connection (shell-wrap-connection) diff --git a/src/connection/debian-sbcl.lisp b/src/connection/debian-sbcl.lisp index ac9925e..0bfc039 100644 --- a/src/connection/debian-sbcl.lisp +++ b/src/connection/debian-sbcl.lisp @@ -22,7 +22,7 @@ (mrun "which sbcl >/dev/null 2>&1 || apt-get -y install sbcl") (request-lisp-systems) (upload-all-prerequisite-data) - (princ "Waiting for remote Lisp to exit, this may take some time ... ") + (inform t "Waiting for remote Lisp to exit, this may take some time ... ") (force-output) (let ((program (continue-deploy*-program remaining))) (multiple-value-bind (out err exit) diff --git a/src/connection/ssh.lisp b/src/connection/ssh.lisp index f4903b5..2098585 100644 --- a/src/connection/ssh.lisp +++ b/src/connection/ssh.lisp @@ -23,7 +23,7 @@ (hop (get-hostname)) user) (declare (ignore remaining)) - (format t "Establishing SSH connection to ~A~%" hop) + (informat 1 "~&Establishing SSH connection to ~A" hop) (mrun "ssh" "-fN" hop) (make-instance 'ssh-connection :hostname hop :user user)) diff --git a/src/connection/sudo.lisp b/src/connection/sudo.lisp index db0111a..3c7c633 100644 --- a/src/connection/sudo.lisp +++ b/src/connection/sudo.lisp @@ -61,7 +61,7 @@ user password) (declare (ignore remaining)) - (format t "Establishing sudo connection to ~A~%" user) + (informat 1 "~&Establishing sudo connection to ~A" user) (make-instance 'sudo-connection :user user ;; we'll send the password followed by ^M, then the real diff --git a/src/data.lisp b/src/data.lisp index d3b9330..55072cf 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -279,10 +279,10 @@ appropriate. Falls back to CONNECTION-WRITEFILE." (let ((*dest* (remote-data-pathname iden1 iden2 data-version))) (declare (special *dest*)) (mrun "mkdir" "-p" (pathname-directory-pathname *dest*)) - (format t "Uploading (~@{~S~^ ~}) ... " iden1 iden2 data-version) + (informat 1 "~&Uploading (~@{~S~^ ~}) ... " iden1 iden2 data-version) (call-next-method) (push (list iden1 iden2 *dest*) (slot-value *connection* 'cached-data)) - (format t "done.~%")))) + (inform 1 "done." :fresh-line nil)))) (defmethod connection-upload-data ((data file-data)) (declare (special *dest*)) @@ -403,10 +403,12 @@ Preprocessing must occur in the root Lisp.")) (lambda (c) (declare (ignore c)) (invoke-restart 'skip-data-source)))) - ,@forms))) + (let ((*consfigurator-debug-level* ,*consfigurator-debug-level*)) + ,@forms)))) (let* ((intern-forms (loop for name in '("MISSING-DATA-SOURCE" - "SKIP-DATA-SOURCE") + "SKIP-DATA-SOURCE" + "*CONSFIGURATOR-DEBUG-LEVEL*") collect `(export (intern ,name (find-package "CONSFIGURATOR")) (find-package "CONSFIGURATOR")))) diff --git a/src/package.lisp b/src/package.lisp index 618005e..7878243 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -54,6 +54,11 @@ #:memstring= #:plist-to-cmd-args + #:*consfigurator-debug-level* + #:with-indented-inform + #:inform + #:informat + #:version< #:version> #:version<= diff --git a/src/property/apt.lisp b/src/property/apt.lisp index 609b581..774af75 100644 --- a/src/property/apt.lisp +++ b/src/property/apt.lisp @@ -24,7 +24,7 @@ (defmacro with-maybe-update (form) `(handler-case ,form (run-failed () - (apt-get :princ "update") + (apt-get :inform "update") ,form))) (define-constant +sections+ '("main" "contrib" "non-free") :test #'equal) @@ -41,7 +41,7 @@ (:check (all-installed-p packages)) (:apply - (with-maybe-update (apt-get :princ "-y" "install" packages)))) + (with-maybe-update (apt-get :inform "-y" "install" packages)))) (defprop removed :posix (&rest packages) "Ensure all of the apt packages PACKAGES are removed." @@ -52,7 +52,7 @@ (:check (none-installed-p packages)) (:apply - (apt-get :princ "-y" "remove" packages))) + (apt-get :inform "-y" "remove" packages))) (defproplist service-installed-running :posix (package) "Where PACKAGE installs a service named PACKAGE, ensure it is installed and diff --git a/src/propspec.lisp b/src/propspec.lisp index dec1c3e..6a06d1f 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -322,14 +322,15 @@ apply the elements of REQUIREMENTS in reverse order." (defun apply-and-print (propapps &optional unapply) (dolist (pa (if unapply (reverse propapps) propapps)) (let* ((result (restart-case - (if unapply (propappunapply pa) (propappapply pa)) + (with-indented-inform + (if unapply (propappunapply pa) (propappapply pa))) (skip-property () :failed-change))) (status (case result (:no-change "ok") (:failed-change "failed") (t "done")))) - (format t "~@[~A :: ~]~@[~A ... ~]~A~%" - (get-hostname) (propappdesc pa) status)))) + (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" + (get-hostname) (propappdesc pa) status)))) (define-function-property-combinator unapply (propapp) (destructuring-bind (psym . args) propapp diff --git a/src/util.lisp b/src/util.lisp index 89c327c..a607f4d 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -131,6 +131,51 @@ supported." (push (strcat "--" (string-downcase (symbol-name k)) "=" v) args))) +;;;; Progress & debug printing + +(defvar *consfigurator-debug-level* nil + "Integer. Higher values mean be more verbose during deploys.") + +(defvar *inform-prefix* ";; ") + +(defmacro with-indented-inform (&body forms) + `(let ((*inform-prefix* (strcat *inform-prefix* " "))) + ,@forms)) + +(defun inform (level output &key strip-empty (fresh-line t)) + "Print something to the user during deploys." + (unless (and (numberp level) (> level *consfigurator-debug-level*)) + (let ((lines (loop for line in (etypecase output + (cons output) + (string (lines output))) + ;; strip (first part of) prefix added by a remote Lisp + for stripped = (if (string-prefix-p ";; " line) + (subseq line 3) + line) + unless (and strip-empty (re:scan #?/\A\s*\z/ stripped)) + collect stripped))) + (when fresh-line + (fresh-line) + (princ *inform-prefix*)) + (princ (pop lines)) + (dolist (line lines) + (fresh-line) + (princ *inform-prefix*) + (princ line))))) + +(defun informat (level control-string &rest format-arguments) + "Print something to the user during deploys using FORMAT. +Be sure to begin CONTROL-STRING with ~& unless you want to continue from +previous output." + (if (string-prefix-p "~&" control-string) + (inform level + (apply #'format nil (subseq control-string 2) format-arguments) + :fresh-line t) + (inform level + (apply #'format nil control-string format-arguments) + :fresh-line nil))) + + ;;;; Version numbers (defun version< (x y) |