hide sudo passwords in the debugger

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

3 files changed, 40 insertions, 8 deletions

diff --git a/src/connection/sudo.lisp b/src/connection/sudo.lisp
index 6612414..935fc5b 100644
--- a/src/connection/sudo.lisp
+++ b/src/connection/sudo.lisp
@@ -52,7 +52,8 @@
 		   as
 		   (destructuring-bind (user host)
 		       (split-string as :separator "@")
-		     (get-data-string (strcat "--user-passwd--" host) user)))))
+		     (get-data-protected-string
+		      (strcat "--user-passwd--" host) user)))))
 
 (defmethod establish-connection ((type (eql :sudo))
 				 remaining
@@ -66,7 +67,9 @@
 		 ;; we'll send the password followed by ^M, then the real
 		 ;; stdin.  use CODE-CHAR in this way so that we can be sure
 		 ;; ASCII ^M is what will get emitted.
-		 :password (strcat password (string (code-char 13)))))
+		 :password (and password
+				(strcat (passphrase password)
+					(string (code-char 13))))))
 
 (defclass sudo-connection (shell-wrap-connection)
   ((user
diff --git a/src/data.lisp b/src/data.lisp
index 2869b43..5315762 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -350,6 +350,32 @@ of the current connection, where each entry is of the form
   "#+sbcl (require \"sb-cltl2\")"
   :test #'equal)
 
+
+;;;; Passphrases
+
+(defclass passphrase ()
+  ((passphrase :initarg :passphrase :reader passphrase)))
+
+(defun get-data-protected-string (iden1 iden2)
+  "Like GET-DATA-STRING, but wrap the content in an object which is unprintable
+by default.  Intended for code which fetches passwords and wants to lessen the
+chance of those passwords showing up in the clear in the Lisp debugger."
+  (make-instance 'passphrase :passphrase (get-data-string iden1 iden2)))
+
+(defvar *allow-printing-passphrases* nil)
+
+(defmethod print-object ((passphrase passphrase) stream)
+  (if *allow-printing-passphrases*
+      (format stream "#.~S"
+	      `(make-instance 'passphrase
+			      :passphrase ,(passphrase passphrase)))
+      (print-unreadable-object (passphrase stream)
+	(format stream "PASSPHRASE")))
+  passphrase)
+
+
+;;;; Programs for remote Lisp images
+
 (defun continue-deploy*-program (remaining-connections)
   "Return a program to complete the work of an enclosing call to DEPLOY*.
 
@@ -402,12 +428,13 @@ Preprocessing must occur in the root Lisp."))
 		    ,(wrap `((%consfigure ',remaining-connections ,*host*))))))
       (handler-case
 	  (with-standard-io-syntax
-	    ;; 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~%~{~A~^~%~}"
-		    +continue-deploy*-program-implementation-specific+
-		    (mapcar #'prin1-to-string forms)))
+	    (let ((*allow-printing-passphrases* t))
+	      ;; 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~%~{~A~^~%~}"
+		      +continue-deploy*-program-implementation-specific+
+		      (mapcar #'prin1-to-string forms))))
 	(print-not-readable (c)
 	  (error "The Lisp printer could not serialise ~A for
 transmission to the remote Lisp.
diff --git a/src/package.lisp b/src/package.lisp
index ed422d8..1d1281e 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -167,6 +167,8 @@
 	   #:get-data-string
 	   #:upload-all-prerequisite-data
 	   #:request-lisp-systems
+	   #:passphrase
+	   #:get-data-protected-string
 	   #:continue-deploy*-program))
 
 (defpackage :consfigurator.connection.shell-wrap