[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 12040 bytes --]

* doc/guix.texi (Invoking guix deploy): Add section describing
prerequisites for deploying as a non-root user.
* guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command'
argument.
(%remote-eval): New optional 'become-command' argument.
(remote-eval): New 'become-command' keyword argument.
* guix/ssh.scm (remote-inferior): New optional 'become-command'
argument.
(inferior-remote-eval): New optional 'become-command' argument.
(remote-authorize-signing-key): New optional 'become-command' argument.
* gnu/machine/ssh.scm (machine-become-command): New variable.
(managed-host-remote-eval): Invoke 'remote-eval' with the
'#:become-command' keyword.
(deploy-managed-host): Invoke 'remote-authorize-signing-key' with the
'#:become-command' keyword.
---
 doc/guix.texi       | 10 ++++++++
 gnu/machine/ssh.scm | 15 ++++++++++--
 guix/remote.scm     | 60 ++++++++++++++++++++++++++++-----------------
 guix/ssh.scm        | 30 ++++++++++++++++-------
 4 files changed, 82 insertions(+), 33 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 64ca44d494..144981af10 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25514,6 +25514,7 @@ evaluates to.  As an example, @var{file} might contain a definition like this:
        (environment managed-host-environment-type)
        (configuration (machine-ssh-configuration
                        (host-name "localhost")
+                       (user "alice")
                        (identity "./id_rsa")
                        (port 2222)))))
 @end example
@@ -25530,6 +25531,15 @@ complex deployment may involve, for example, starting virtual machines through
 a Virtual Private Server (VPS) provider.  In such a case, a different
 @var{environment} type would be used.
 
+@code{user}, in this example, specifies the name of the user account to log in
+as to perform the deployment.  Its default value is @code{root}, but root
+login over SSH may be forbidden in some cases.  To work around this,
+@command{guix deploy} can log in as an unprivileged user and employ
+@code{sudo} to escalate privileges.  This will only work if @code{sudo} is
+currently installed on the remote and can be invoked non-interactively as
+@code{user}.  That is: the line in @code{sudoers} granting @code{user} the
+ability to use @code{sudo} must contain the NOPASSWD tag.
+
 @deftp {Data Type} machine
 This is the data type representing a single machine in a heterogeneous Guix
 deployment.
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 90deff19a8..083e443a16 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -105,6 +105,14 @@ one from the configuration's parameters if one was not provided."
 ;;; Remote evaluation.
 ;;;
 
+(define (machine-become-command machine)
+  "Return as a list of strings the program and arguments necessary to run a
+shell command with escalated privileges for MACHINE's configuration."
+  (if (string= "root" (machine-ssh-configuration-user
+                       (machine-configuration machine)))
+      '()
+      '("/run/setuid-programs/sudo" "-n" "--")))
+
 (define (managed-host-remote-eval machine exp)
   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 an environment type of 'managed-host."
@@ -112,7 +120,9 @@ an environment type of 'managed-host."
   (remote-eval exp (machine-ssh-session machine)
                #:build-locally?
                (machine-ssh-configuration-build-locally?
-                (machine-configuration machine))))
+                (machine-configuration machine))
+               #:become-command
+               (machine-become-command machine)))
 
 \f
 ;;;
@@ -335,7 +345,8 @@ environment type of 'managed-host."
   (remote-authorize-signing-key (call-with-input-file %public-key-file
                                   (lambda (port)
                                     (string->canonical-sexp (get-string-all port))))
-                                (machine-ssh-session machine))
+                                (machine-ssh-session machine)
+                                (machine-become-command machine))
   (mlet %store-monad ((_ (check-deployment-sanity machine))
                       (boot-parameters (machine-boot-parameters machine)))
     (let* ((os (machine-operating-system machine))
diff --git a/guix/remote.scm b/guix/remote.scm
index d5738ebbfa..d5992763b2 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -27,6 +27,8 @@
   #:use-module (guix utils)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (remote-eval))
 
@@ -41,29 +43,41 @@
 ;;;
 ;;; Code:
 
-(define (remote-pipe-for-gexp lowered session)
-  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
   (define shell-quote
     (compose object->string object->string))
 
-  (apply open-remote-pipe* session OPEN_READ
-         (string-append (derivation-input-output-path
-                         (lowered-gexp-guile lowered))
-                        "/bin/guile")
-         "--no-auto-compile"
-         (append (append-map (lambda (directory)
-                               `("-L" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 (append-map (lambda (directory)
-                               `("-C" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 `("-c"
-                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+  (define repl-command
+    (append (or become-command '())
+            (list
+             (string-append (derivation-input-output-path
+                             (lowered-gexp-guile lowered))
+                            "/bin/guile")
+             "--no-auto-compile")
+            (append-map (lambda (directory)
+                          `("-L" ,directory))
+                        (lowered-gexp-load-path lowered))
+            (append-map (lambda (directory)
+                          `("-C" ,directory))
+                        (lowered-gexp-load-path lowered))
+            `("-c"
+              ,(shell-quote (lowered-gexp-sexp lowered)))))
 
-(define (%remote-eval lowered session)
+  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
+    pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
-  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
          (result (read-repl-response pipe)))
     (close-port pipe)
     result))
@@ -91,12 +105,14 @@ result to the current output port using the (guix repl) protocol."
                       #:key
                       (build-locally? #t)
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket"))
+                      (socket-name "/var/guix/daemon-socket/socket")
+                      (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 the remote store afterwards; otherwise, dependencies are built directly on the
-remote store."
+remote store.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
   (mlet* %store-monad ((system -> (remote-system session))
                        (lowered (lower-gexp (trampoline exp)
                                             #:system system
@@ -119,7 +135,7 @@ remote store."
             (built-derivations inputs)
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (close-connection remote))
-            (return (%remote-eval lowered session))))
+            (return (%remote-eval lowered session become-command))))
         (let ((to-send (append (map (compose derivation-file-name
                                              derivation-input-derivation)
                                     inputs)
@@ -128,4 +144,4 @@ remote store."
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (build-derivations remote inputs))
             (return (close-connection remote))
-            (return (%remote-eval lowered session)))))))
+            (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 5186c646ca..7bc499a2fe 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -100,16 +100,27 @@ specifies; otherwise use them.  Throw an error on failure."
                 (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                  host (get-error session))))))))))
 
-(define (remote-inferior session)
-  "Return a remote inferior for the given SESSION."
-  (let ((pipe (open-remote-pipe* session OPEN_BOTH
-                                 "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+  (let* ((repl-command (append (or become-command '())
+                               '("guix" "repl" "-t" "machine")))
+         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
+    ;; process does succeed. This doesn't reflect the documentation, so it's
+    ;; possible that it's a bug in guile-ssh.
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
     (port->inferior pipe)))
 
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
   "Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
-  (let ((inferior (remote-inferior session)))
+right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+  (let ((inferior (remote-inferior session become-command)))
     (dynamic-wind
       (const #t)
       (lambda ()
@@ -291,7 +302,7 @@ the machine on the other end of SESSION."
   (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
                         session))
 
-(define (remote-authorize-signing-key key session)
+(define* (remote-authorize-signing-key key session #:optional become-command)
   "Send KEY, a canonical sexp containing a public key, over SESSION and add it
 to the system ACL file if it has not yet been authorized."
   (inferior-remote-eval
@@ -310,7 +321,8 @@ to the system ACL file if it has not yet been authorized."
           (mkdir-p (dirname %acl-file))
           (with-atomic-file-output %acl-file
             (cut write-acl acl <>)))))
-   session))
+   session
+   become-command))
 
 (define* (send-files local files remote
                      #:key
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Ricardo Wurmus]

Hi Jakob,

I haven’t yet looked over the patches, but when I saw that it mentions
“sudo” I wondered: is it feasible to support “su” with interactive (or
cached) password input as well?

-- 
Ricardo

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Christopher Lemmer Webber]

Ricardo Wurmus writes:

> Hi Jakob,
>
> I haven’t yet looked over the patches, but when I saw that it mentions
> “sudo” I wondered: is it feasible to support “su” with interactive (or
> cached) password input as well?

Maybe a more important question: if this turns out to be desirable, is
there a path forward to add it later?  If that's true, I'd suggest we
move forward with merging the patch and worry about how to add the
option at a future time.

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 1628 bytes --]

Hi Ricardo and Chris,

Ricardo Wurmus <rekado@elephly.net> writes:

> Hi Jakob,
>
> I haven’t yet looked over the patches, but when I saw that it mentions
> “sudo” I wondered: is it feasible to support “su” with interactive (or
> cached) password input as well?

I believe so. This would require two additions:

- Code to interact with the 'su' prompt.
- Some way for 'managed-host-environment-type' to obtain root's
  password, which I imagine would be either a prompt or a field in the
  configuration record.

On the latter addition, I've experimented a bit with both possibilities
(albeit for a password-authenticated sudo). Prompting the user for a
password feels like a bad idea because then deployments wouldn't really
be automated, and we would have to do some sort of thread
synchronization when parallel deployments are implemented so we don't
mess up the TTY. I could get behind a 'password' field for
'managed-host-environment-type' (and then if users want a prompt they
can just call out to 'getpass'), but again, we'd need code to interact
with the 'su' prompt.

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Maybe a more important question: if this turns out to be desirable, is
> there a path forward to add it later? If that's true, I'd suggest we
> move forward with merging the patch and worry about how to add the
> option at a future time.

Yeah. A 'password' field with '(default #f)' shouldn't be too invasive.
Aside from that, it would just involve adding the 'su' interaction code
to the two procedures that spawn REPLs.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Ricardo Wurmus]

Hi Jakob,

>> I haven’t yet looked over the patches, but when I saw that it mentions
>> “sudo” I wondered: is it feasible to support “su” with interactive (or
>> cached) password input as well?
>
> I believe so. This would require two additions:
>
> - Code to interact with the 'su' prompt.
> - Some way for 'managed-host-environment-type' to obtain root's
>   password, which I imagine would be either a prompt or a field in the
>   configuration record.

Sounds good.  IIRC Ansible has support for both sudo and su, so it’s
good that there’s a way to do both in the future.

Thanks!

-- 
Ricardo

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 309 bytes --]

Hi Ricardo,

Ricardo Wurmus <rekado@elephly.net> writes:

> Sounds good. IIRC Ansible has support for both sudo and su, so it’s
> good that there’s a way to do both in the future.
>
> Thanks!

That's what I modeled this after, albeit without support for a password
prompt :)

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH] machine: Allow non-root users to deploy.

[Christopher Lemmer Webber]

It looks good, but needs a rebase before merge.  Jakob, do you mind handling?

[bug#36957] [PATCH v2] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 10512 bytes --]

* doc/guix.texi (Invoking guix deploy): Add section describe
prerequisites for deploying as a non-root user.
* guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command'
argument.
(%remote-eval): New optional 'become-command' argument.
(remote-eval): New 'become-command' keyword argument.
* guix/ssh.scm (remote-inferior): New optional 'become-command'
argument.
(inferior-remote-eval): New optional 'become-command' argument.
(remote-authorize-signing-key): New optional 'become-command' argument.
* gnu/machine/ssh.scm (machine-become-command): New variable.
(managed-host-remote-eval): Invoke 'remote-eval' with the
'#:become-command' keyword.
(deploy-managed-host): Invoke 'remote-authorize-signing-key' with the
'#:become-command' keyword.
---
 doc/guix.texi       | 10 ++++++++
 gnu/machine/ssh.scm | 12 ++++++++-
 guix/remote.scm     | 60 ++++++++++++++++++++++++++++-----------------
 guix/ssh.scm        | 25 +++++++++++++------
 4 files changed, 77 insertions(+), 30 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 734206a4b2..1f0750255d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25514,6 +25514,7 @@ evaluates to.  As an example, @var{file} might contain a definition like this:
        (environment managed-host-environment-type)
        (configuration (machine-ssh-configuration
                        (host-name "localhost")
+                       (user "alice")
                        (identity "./id_rsa")
                        (port 2222)))))
 @end example
@@ -25546,6 +25547,15 @@ accepts store items it receives from the coordinator:
 # guix archive --authorize < coordinator-public-key.txt
 @end example
 
+@code{user}, in this example, specifies the name of the user account to log in
+as to perform the deployment.  Its default value is @code{root}, but root
+login over SSH may be forbidden in some cases.  To work around this,
+@command{guix deploy} can log in as an unprivileged user and employ
+@code{sudo} to escalate privileges.  This will only work if @code{sudo} is
+currently installed on the remote and can be invoked non-interactively as
+@code{user}.  That is: the line in @code{sudoers} granting @code{user} the
+ability to use @code{sudo} must contain the NOPASSWD tag.
+
 @deftp {Data Type} machine
 This is the data type representing a single machine in a heterogeneous Guix
 deployment.
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index ba3e33c922..aba98f8de5 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -99,6 +99,14 @@ one from the configuration's parameters if one was not provided."
 ;;; Remote evaluation.
 ;;;
 
+(define (machine-become-command machine)
+  "Return as a list of strings the program and arguments necessary to run a
+shell command with escalated privileges for MACHINE's configuration."
+  (if (string= "root" (machine-ssh-configuration-user
+                       (machine-configuration machine)))
+      '()
+      '("/run/setuid-programs/sudo" "-n" "--")))
+
 (define (managed-host-remote-eval machine exp)
   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 an environment type of 'managed-host."
@@ -106,7 +114,9 @@ an environment type of 'managed-host."
   (remote-eval exp (machine-ssh-session machine)
                #:build-locally?
                (machine-ssh-configuration-build-locally?
-                (machine-configuration machine))))
+                (machine-configuration machine))
+               #:become-command
+               (machine-become-command machine)))
 
 \f
 ;;;
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..b0b6afba93 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (remote-eval))
 
@@ -40,29 +42,41 @@
 ;;;
 ;;; Code:
 
-(define (remote-pipe-for-gexp lowered session)
-  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
   (define shell-quote
     (compose object->string object->string))
 
-  (apply open-remote-pipe* session OPEN_READ
-         (string-append (derivation-input-output-path
-                         (lowered-gexp-guile lowered))
-                        "/bin/guile")
-         "--no-auto-compile"
-         (append (append-map (lambda (directory)
-                               `("-L" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 (append-map (lambda (directory)
-                               `("-C" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 `("-c"
-                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+  (define repl-command
+    (append (or become-command '())
+            (list
+             (string-append (derivation-input-output-path
+                             (lowered-gexp-guile lowered))
+                            "/bin/guile")
+             "--no-auto-compile")
+            (append-map (lambda (directory)
+                          `("-L" ,directory))
+                        (lowered-gexp-load-path lowered))
+            (append-map (lambda (directory)
+                          `("-C" ,directory))
+                        (lowered-gexp-load-path lowered))
+            `("-c"
+              ,(shell-quote (lowered-gexp-sexp lowered)))))
 
-(define (%remote-eval lowered session)
+  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
+    pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
-  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
          (result (read-repl-response pipe)))
     (close-port pipe)
     result))
@@ -90,12 +104,14 @@ result to the current output port using the (guix repl) protocol."
                       #:key
                       (build-locally? #t)
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket"))
+                      (socket-name "/var/guix/daemon-socket/socket")
+                      (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 the remote store afterwards; otherwise, dependencies are built directly on the
-remote store."
+remote store.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
   (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
                                            #:module-path %load-path))
                       (remote -> (connect-to-remote-daemon session
@@ -115,7 +131,7 @@ remote store."
             (built-derivations inputs)
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (close-connection remote))
-            (return (%remote-eval lowered session))))
+            (return (%remote-eval lowered session become-command))))
         (let ((to-send (append (map (compose derivation-file-name
                                              derivation-input-derivation)
                                     inputs)
@@ -124,4 +140,4 @@ remote store."
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (build-derivations remote inputs))
             (return (close-connection remote))
-            (return (%remote-eval lowered session)))))))
+            (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ede00133c8..0f65f9e65b 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -97,16 +97,27 @@ specifies; otherwise use them.  Throw an error on failure."
                 (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                  host (get-error session))))))))))
 
-(define (remote-inferior session)
-  "Return a remote inferior for the given SESSION."
-  (let ((pipe (open-remote-pipe* session OPEN_BOTH
-                                 "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+  (let* ((repl-command (append (or become-command '())
+                               '("guix" "repl" "-t" "machine")))
+         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
+    ;; process does succeed. This doesn't reflect the documentation, so it's
+    ;; possible that it's a bug in guile-ssh.
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
     (port->inferior pipe)))
 
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
   "Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
-  (let ((inferior (remote-inferior session)))
+right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+  (let ((inferior (remote-inferior session become-command)))
     (dynamic-wind
       (const #t)
       (lambda ()
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH v2] machine: Allow non-root users to deploy.

[Ricardo Wurmus]

Hi Jakob,

> +@code{user}.  That is: the line in @code{sudoers} granting @code{user} the
> +ability to use @code{sudo} must contain the NOPASSWD tag.

Perhaps also wrap “NOPASSWD” in @code{…}.

> +(define (machine-become-command machine)
> +  "Return as a list of strings the program and arguments necessary to run a
> +shell command with escalated privileges for MACHINE's configuration."
> +  (if (string= "root" (machine-ssh-configuration-user
> +                       (machine-configuration machine)))
> +      '()
> +      '("/run/setuid-programs/sudo" "-n" "--")))
> +

This is a comment for future changes only: currently, we can assume that
the remote machine already runs Guix System.  In the future “guix
deploy” should probably also be able to initialize a system.  In that
case “sudo” may have to be searched on the target or otherwise be
provided.

(What happens if /run/setuid-programs/sudo is not available on the
target machine?)

> +(define* (%remote-eval lowered session #:optional become-command)
>    "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
> -prerequisites of EXP are already available on the host at SESSION."
> -  (let* ((pipe   (remote-pipe-for-gexp lowered session))
> +prerequisites of EXP are already available on the host at SESSION.  If
> +BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
> +  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
>           (result (read-repl-response pipe)))
>      (close-port pipe)
>      result))
> @@ -90,12 +104,14 @@ result to the current output port using the (guix repl) protocol."
>                        #:key
>                        (build-locally? #t)
>                        (module-path %load-path)
> -                      (socket-name "/var/guix/daemon-socket/socket"))
> +                      (socket-name "/var/guix/daemon-socket/socket")
> +                      (become-command #f))

I’m just stumbling upon “socket-name”.  “/var/guix” is not guaranteed to
be the localstatedir.  It would be better to use (guix config) to
determine the configured value.

This doesn’t block this patch, of course, but it would be good to change
this in the future.

--
Ricardo

[bug#36957] [PATCH v2] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 1277 bytes --]

Hey Ricardo,

Ricardo Wurmus <rekado@elephly.net> writes:

> Perhaps also wrap “NOPASSWD” in @code{…}.

Got it, thanks!

> This is a comment for future changes only: currently, we can assume that
> the remote machine already runs Guix System.  In the future “guix
> deploy” should probably also be able to initialize a system.  In that
> case “sudo” may have to be searched on the target or otherwise be
> provided.

Ah, that's a good point. I'd imagine that would involve changing a few
other things with how the REPL is spawned, too.

> (What happens if /run/setuid-programs/sudo is not available on the
> target machine?)

I'm a bit short on time before boarding this flight, so I can't test it
out at the moment, but I'm pretty sure the "failed to run..." message
condition would be thrown. I'll check and get back to you.

> I’m just stumbling upon “socket-name”.  “/var/guix” is not guaranteed to
> be the localstatedir.  It would be better to use (guix config) to
> determine the configured value.
>
> This doesn’t block this patch, of course, but it would be good to change
> this in the future.

Right, yeah. I may submit a separate patch for it shortly since it
should be a simple change.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH v2] machine: Allow non-root users to deploy.

[Christopher Lemmer Webber]

Jakob L. Kreuze writes:

>> (What happens if /run/setuid-programs/sudo is not available on the
>> target machine?)
>
> I'm a bit short on time before boarding this flight, so I can't test it
> out at the moment, but I'm pretty sure the "failed to run..." message
> condition would be thrown. I'll check and get back to you.

Check, and if that's good, let's merge this in the patch series tomorrow.

>> I’m just stumbling upon “socket-name”.  “/var/guix” is not guaranteed to
>> be the localstatedir.  It would be better to use (guix config) to
>> determine the configured value.
>>
>> This doesn’t block this patch, of course, but it would be good to change
>> this in the future.
>
> Right, yeah. I may submit a separate patch for it shortly since it
> should be a simple change.

See if you can get it in the patch series (as the last patch)!  If you
can't, file a bug, and let's not block on it.

[bug#36957] [PATCH 0/5] Consolidated patches for guix deploy

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 1016 bytes --]

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Check, and if that's good, let's merge this in the patch series
> tomorrow.

As predicted, it handles a missing 'sudo' just fine :]

> See if you can get it in the patch series (as the last patch)! If you
> can't, file a bug, and let's not block on it.

Got it in! Pretty simple change.

Jakob L. Kreuze (5):
  machine: Allow non-root users to deploy.
  machine: Implement 'roll-back-machine'.
  machine: Automatically authorize the coordinator's signing key.
  doc: Add description of 'build-locally?'.
  remote: Use (%daemon-socket-uri) rather than hard-coded path.

 doc/guix.texi           |  15 ++++++
 gnu/machine.scm         |  27 +++++++++-
 gnu/machine/ssh.scm     | 113 ++++++++++++++++++++++++++++++++++++----
 guix/remote.scm         |  57 ++++++++++++--------
 guix/scripts/deploy.scm |  17 +++++-
 guix/ssh.scm            |  48 ++++++++++++++---
 6 files changed, 236 insertions(+), 41 deletions(-)

-- 
2.22.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH 1/5] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 9739 bytes --]

* doc/guix.texi (Invoking guix deploy): Add section describing
prerequisites for deploying as a non-root user.
* guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command'
argument.
(%remote-eval): New optional 'become-command' argument.
(remote-eval): New 'become-command' keyword argument.
* guix/ssh.scm (remote-inferior): New optional 'become-command'
argument.  
(inferior-remote-eval): New optional 'become-command' argument.
(remote-authorize-signing-key): New optional 'become-command' argument.
* gnu/machine/ssh.scm (machine-become-command): New variable.
(managed-host-remote-eval): Invoke 'remote-eval' with the
'#:become-command' keyword.
(deploy-managed-host): Invoke 'remote-authorize-signing-key' with the
'#:become-command' keyword.
---
 doc/guix.texi       | 10 ++++++++
 gnu/machine/ssh.scm |  8 +++++++
 guix/remote.scm     | 57 ++++++++++++++++++++++++++++-----------------
 guix/ssh.scm        | 25 ++++++++++++++------
 4 files changed, 72 insertions(+), 28 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index a7facf4701..e5cec7ad25 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25514,6 +25514,7 @@ evaluates to.  As an example, @var{file} might contain a definition like this:
        (environment managed-host-environment-type)
        (configuration (machine-ssh-configuration
                        (host-name "localhost")
+                       (user "alice")
                        (identity "./id_rsa")
                        (port 2222)))))
 @end example
@@ -25546,6 +25547,15 @@ accepts store items it receives from the coordinator:
 # guix archive --authorize < coordinator-public-key.txt
 @end example
 
+@code{user}, in this example, specifies the name of the user account to log in
+as to perform the deployment.  Its default value is @code{root}, but root
+login over SSH may be forbidden in some cases.  To work around this,
+@command{guix deploy} can log in as an unprivileged user and employ
+@code{sudo} to escalate privileges.  This will only work if @code{sudo} is
+currently installed on the remote and can be invoked non-interactively as
+@code{user}.  That is: the line in @code{sudoers} granting @code{user} the
+ability to use @code{sudo} must contain the @code{NOPASSWD} tag.
+
 @deftp {Data Type} machine
 This is the data type representing a single machine in a heterogeneous Guix
 deployment.
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 670990a633..fb15d39e61 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -101,6 +101,14 @@ one from the configuration's parameters if one was not provided."
 ;;; Remote evaluation.
 ;;;
 
+(define (machine-become-command machine)
+  "Return as a list of strings the program and arguments necessary to run a
+shell command with escalated privileges for MACHINE's configuration."
+  (if (string= "root" (machine-ssh-configuration-user
+                       (machine-configuration machine)))
+      '()
+      '("/run/setuid-programs/sudo" "-n" "--")))
+
 (define (managed-host-remote-eval machine exp)
   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 an environment type of 'managed-host."
diff --git a/guix/remote.scm b/guix/remote.scm
index bcac64ea7a..d8124e41ab 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -27,6 +27,8 @@
   #:use-module (guix utils)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (remote-eval))
 
@@ -41,29 +43,41 @@
 ;;;
 ;;; Code:
 
-(define (remote-pipe-for-gexp lowered session)
-  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
   (define shell-quote
     (compose object->string object->string))
 
-  (apply open-remote-pipe* session OPEN_READ
-         (string-append (derivation-input-output-path
-                         (lowered-gexp-guile lowered))
-                        "/bin/guile")
-         "--no-auto-compile"
-         (append (append-map (lambda (directory)
-                               `("-L" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 (append-map (lambda (directory)
-                               `("-C" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 `("-c"
-                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+  (define repl-command
+    (append (or become-command '())
+            (list
+             (string-append (derivation-input-output-path
+                             (lowered-gexp-guile lowered))
+                            "/bin/guile")
+             "--no-auto-compile")
+            (append-map (lambda (directory)
+                          `("-L" ,directory))
+                        (lowered-gexp-load-path lowered))
+            (append-map (lambda (directory)
+                          `("-C" ,directory))
+                        (lowered-gexp-load-path lowered))
+            `("-c"
+              ,(shell-quote (lowered-gexp-sexp lowered)))))
 
-(define (%remote-eval lowered session)
+  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
+    pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
-  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
          (result (read-repl-response pipe)))
     (close-port pipe)
     result))
@@ -92,7 +106,8 @@ result to the current output port using the (guix repl) protocol."
                       (build-locally? #t)
                       (system (%current-system))
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket"))
+                      (socket-name "/var/guix/daemon-socket/socket")
+                      (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
@@ -119,7 +134,7 @@ remote store."
             (built-derivations inputs)
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (close-connection remote))
-            (return (%remote-eval lowered session))))
+            (return (%remote-eval lowered session become-command))))
         (let ((to-send (append (map (compose derivation-file-name
                                              derivation-input-derivation)
                                     inputs)
@@ -128,4 +143,4 @@ remote store."
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (build-derivations remote inputs))
             (return (close-connection remote))
-            (return (%remote-eval lowered session)))))))
+            (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 9b5ca68894..90311127a1 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -98,16 +98,27 @@ specifies; otherwise use them.  Throw an error on failure."
                 (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                  host (get-error session))))))))))
 
-(define (remote-inferior session)
-  "Return a remote inferior for the given SESSION."
-  (let ((pipe (open-remote-pipe* session OPEN_BOTH
-                                 "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+  (let* ((repl-command (append (or become-command '())
+                               '("guix" "repl" "-t" "machine")))
+         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
+    ;; process does succeed. This doesn't reflect the documentation, so it's
+    ;; possible that it's a bug in guile-ssh.
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
     (port->inferior pipe)))
 
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
   "Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
-  (let ((inferior (remote-inferior session)))
+right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+  (let ((inferior (remote-inferior session become-command)))
     (dynamic-wind
       (const #t)
       (lambda ()
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH 2/5] machine: Implement 'roll-back-machine'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 9050 bytes --]

* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
---
 gnu/machine.scm         | 27 +++++++++++++++-
 gnu/machine/ssh.scm     | 72 +++++++++++++++++++++++++++++++++++++++--
 guix/scripts/deploy.scm | 17 ++++++++--
 3 files changed, 110 insertions(+), 6 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -24,6 +24,7 @@
   #:use-module (guix records)
   #:use-module (guix store)
   #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module (srfi srfi-35)
   #:export (environment-type
             environment-type?
             environment-type-name
@@ -40,7 +41,13 @@
             machine-display-name
 
             deploy-machine
-            machine-remote-eval))
+            roll-back-machine
+            machine-remote-eval
+
+            &deploy-error
+            deploy-error?
+            deploy-error-should-roll-back
+            deploy-error-captured-args))
 
 ;;; Commentary:
 ;;;
@@ -66,6 +73,7 @@
   ;; of the form '(machine-remote-eval machine exp)'.
   (machine-remote-eval environment-type-machine-remote-eval) ; procedure
   (deploy-machine      environment-type-deploy-machine)      ; procedure
+  (roll-back-machine   environment-type-roll-back-machine)   ; procedure
 
   ;; Metadata.
   (name        environment-type-name)       ; symbol
@@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
 MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
   (let ((environment (machine-environment machine)))
     ((environment-type-deploy-machine environment) machine)))
+
+(define (roll-back-machine machine)
+  "Monadic procedure rolling back to the previous system generation on
+MACHINE. Return the number of the generation that was current before switching
+and the new generation number."
+  (let ((environment (machine-environment machine)))
+    ((environment-type-roll-back-machine environment) machine)))
+
+\f
+;;;
+;;; Error types.
+;;;
+
+(define-condition-type &deploy-error &error
+  deploy-error?
+  (should-roll-back deploy-error-should-roll-back)
+  (captured-args deploy-error-captured-args))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index fb15d39e61..4b5d5fe3a2 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu machine ssh)
+  #:use-module (gnu bootloader)
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
@@ -34,6 +35,7 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -341,6 +343,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
                            (boot-parameters-kernel-arguments params))))))))
           generations))))
 
+(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
+  "Catch exceptions that arise when binding MBODY, a monadic expression in
+%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
+the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
+  (catch #t
+    (lambda ()
+      mbody ...)
+    (lambda args
+      (raise (condition (&deploy-error
+                         (should-roll-back should-roll-back?)
+                         (captured-args args)))))))
+
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
@@ -353,9 +367,60 @@ environment type of 'managed-host."
            (bootloader-configuration (operating-system-bootloader os))
            (bootcfg (operating-system-bootcfg os menu-entries)))
       (mbegin %store-monad
-        (switch-to-system eval os)
-        (upgrade-shepherd-services eval os)
-        (install-bootloader eval bootloader-configuration bootcfg)))))
+        (with-roll-back #f
+          (switch-to-system eval os))
+        (with-roll-back #t
+          (mbegin %store-monad
+            (upgrade-shepherd-services eval os)
+            (install-bootloader eval bootloader-configuration bootcfg)))))))
+
+\f
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-managed-host machine)
+  "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'managed-host."
+  (define remote-exp
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((guix config)
+                                                      (guix profiles)))
+        #~(begin
+            (use-modules (guix config)
+                         (guix profiles))
+
+            (define %system-profile
+              (string-append %state-directory "/profiles/system"))
+
+            (define target-generation
+              (relative-generation %system-profile -1))
+
+            (if target-generation
+                (switch-to-generation %system-profile target-generation)
+                'error)))))
+
+  (define roll-back-failure
+    (condition (&message (message (G_ "could not roll-back machine")))))
+
+  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
+                       (_ -> (if (< (length boot-parameters) 2)
+                                 (raise roll-back-failure)))
+                       (entries -> (map boot-parameters->menu-entry
+                                        (list (second boot-parameters))))
+                       (old-entries -> (map boot-parameters->menu-entry
+                                            (drop boot-parameters 2)))
+                       (bootloader -> (operating-system-bootloader
+                                       (machine-operating-system machine)))
+                       (bootcfg (lower-object
+                                 ((bootloader-configuration-file-generator
+                                   (bootloader-configuration-bootloader
+                                    bootloader))
+                                  bootloader entries
+                                  #:old-entries old-entries)))
+                       (remote-result (machine-remote-eval machine remote-exp)))
+    (when (eqv? 'error remote-result)
+      (raise roll-back-failure))))
 
 \f
 ;;;
@@ -366,6 +431,7 @@ environment type of 'managed-host."
   (environment-type
    (machine-remote-eval managed-host-remote-eval)
    (deploy-machine      deploy-managed-host)
+   (roll-back-machine   roll-back-managed-host)
    (name                'managed-host-environment-type)
    (description         "Provisioning for machines that are accessible over SSH
 and have a known host-name. This entails little more than maintaining an SSH
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 81f2b33260..6a67985c8b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
   #:use-module (guix grafts)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:export (guix-deploy))
 
@@ -88,7 +90,18 @@ Perform the deployment specified by FILE.\n"))
     (with-store store
       (set-build-options-from-command-line store opts)
       (for-each (lambda (machine)
-                  (info (G_ "deploying to ~a...") (machine-display-name machine))
+                  (info (G_ "deploying to ~a...~%")
+                        (machine-display-name machine))
                   (parameterize ((%graft? (assq-ref opts 'graft?)))
-                    (run-with-store store (deploy-machine machine))))
+                    (guard (c ((message-condition? c)
+                               (report-error (G_ "failed to deploy ~a: '~a'~%")
+                                             (machine-display-name machine)
+                                             (condition-message c)))
+                              ((deploy-error? c)
+                               (when (deploy-error-should-roll-back c)
+                                 (info (G_ "rolling back ~a...~%")
+                                       (machine-display-name machine))
+                                 (run-with-store store (roll-back-machine machine)))
+                               (apply throw (deploy-error-captured-args c))))
+                      (run-with-store store (deploy-machine machine)))))
                 machines))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH 3/5] machine: Automatically authorize the coordinator's signing key.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 6563 bytes --]

* guix/ssh.scm (remote-authorize-signing-key): New variable.
* gnu/machine/ssh.scm (deploy-managed-host): Authorize coordinator's
signing key before any invocations of 'remote-eval'.
(deploy-managed-host): Display an error if a signing key does not exist.
* doc/guix.texi (Invoking guix deploy): Remove section describing manual
signing key authorization.
(Invoking guix deploy): Add section describing the 'authorize?' field.
---
 doc/guix.texi       |  3 +++
 gnu/machine/ssh.scm | 33 ++++++++++++++++++++++++++-------
 guix/ssh.scm        | 23 +++++++++++++++++++++++
 3 files changed, 52 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index e5cec7ad25..d80f62970d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25586,6 +25586,9 @@ with an @code{environment} of @code{managed-host-environment-type}.
 @item @code{system}
 The Nix system type describing the architecture of the machine being deployed
 to. This should look something like ``x86_64-linux''.
+@item @code{authorize?} (default: @code{#t})
+If true, the coordinator's signing key will be added to the remote's ACL
+keyring.
 @item @code{port} (default: @code{22})
 @item @code{user} (default: @code{"root"})
 @item @code{identity} (default: @code{#f})
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 4b5d5fe3a2..ac3aa3e370 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -28,13 +28,16 @@
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix monads)
+  #:use-module (guix pki)
   #:use-module (guix records)
   #:use-module (guix remote)
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -48,6 +51,7 @@
 
             machine-ssh-configuration-host-name
             machine-ssh-configuration-build-locally?
+            machine-ssh-configuration-authorize?
             machine-ssh-configuration-port
             machine-ssh-configuration-user
             machine-ssh-configuration-session))
@@ -70,17 +74,19 @@
   make-machine-ssh-configuration
   machine-ssh-configuration?
   this-machine-ssh-configuration
-  (host-name      machine-ssh-configuration-host-name) ; string
-  (system         machine-ssh-configuration-system)    ; string
-  (build-locally? machine-ssh-configuration-build-locally?
+  (host-name      machine-ssh-configuration-host-name)     ; string
+  (system         machine-ssh-configuration-system)        ; string
+  (build-locally? machine-ssh-configuration-build-locally? ; boolean
                   (default #t))
-  (port           machine-ssh-configuration-port       ; integer
+  (authorize?     machine-ssh-configuration-authorize?     ; boolean
+                  (default #t))
+  (port           machine-ssh-configuration-port           ; integer
                   (default 22))
-  (user           machine-ssh-configuration-user       ; string
+  (user           machine-ssh-configuration-user           ; string
                   (default "root"))
-  (identity       machine-ssh-configuration-identity   ; path to a private key
+  (identity       machine-ssh-configuration-identity       ; path to a private key
                   (default #f))
-  (session        machine-ssh-configuration-session    ; session
+  (session        machine-ssh-configuration-session        ; session
                   (default #f)))
 
 (define (machine-ssh-session machine)
@@ -359,6 +365,19 @@ the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
+  (when (machine-ssh-configuration-authorize?
+         (machine-configuration machine))
+    (unless (file-exists? %public-key-file)
+      (raise (condition
+              (&message
+               (message (format #f (G_ "no signing key '~a'. \
+have you run 'guix archive --generate-key?'")
+                                %public-key-file))))))
+    (remote-authorize-signing-key (call-with-input-file %public-key-file
+                                    (lambda (port)
+                                      (string->canonical-sexp
+                                       (get-string-all port))))
+                                  (machine-ssh-session machine)))
   (mlet %store-monad ((_ (check-deployment-sanity machine))
                       (boot-parameters (machine-boot-parameters machine)))
     (let* ((os (machine-operating-system machine))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 90311127a1..24834c6f68 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -21,6 +21,7 @@
   #:use-module (guix inferior)
   #:use-module (guix i18n)
   #:use-module ((guix utils) #:select (&fix-hint))
+  #:use-module (gcrypt pk-crypto)
   #:use-module (ssh session)
   #:use-module (ssh auth)
   #:use-module (ssh key)
@@ -40,6 +41,7 @@
             remote-daemon-channel
             connect-to-remote-daemon
             remote-system
+            remote-authorize-signing-key
             send-files
             retrieve-files
             retrieve-files*
@@ -300,6 +302,27 @@ the machine on the other end of SESSION."
   (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
                         session))
 
+(define (remote-authorize-signing-key key session)
+  "Send KEY, a canonical sexp containing a public key, over SESSION and add it
+to the system ACL file if it has not yet been authorized."
+  (inferior-remote-eval
+   `(begin
+      (use-modules (guix build utils)
+                   (guix pki)
+                   (guix utils)
+                   (gcrypt pk-crypto)
+                   (srfi srfi-26))
+
+      (define acl (current-acl))
+      (define key (string->canonical-sexp ,(canonical-sexp->string key)))
+
+      (unless (authorized-key? key)
+        (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
+          (mkdir-p (dirname %acl-file))
+          (with-atomic-file-output %acl-file
+            (cut write-acl acl <>)))))
+   session))
+
 (define* (send-files local files remote
                      #:key
                      recursive?
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH 4/5] doc: Add description of 'build-locally?'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 754 bytes --]

* doc/guix.texi (Invoking guix deploy): Add section describing the
'build-locally?' field of 'managed-host-environment-type'.
---
 doc/guix.texi | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index d80f62970d..043851e418 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25583,6 +25583,8 @@ with an @code{environment} of @code{managed-host-environment-type}.
 
 @table @asis
 @item @code{host-name}
+@item @code{build-locally?} (default: @code{#t})
+If false, system derivations will be built on the machine being deployed to.
 @item @code{system}
 The Nix system type describing the architecture of the machine being deployed
 to. This should look something like ``x86_64-linux''.
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH 5/5] remote: Use (%daemon-socket-uri) rather than hard-coded path.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 919 bytes --]

* guix/remote.scm (remote-eval): Use (%daemon-socket-uri) as the default
value of 'socket-name' rather than hard-coded path.
---
 guix/remote.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/remote.scm b/guix/remote.scm
index d8124e41ab..ae2fe17dd2 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -106,7 +106,7 @@ result to the current output port using the (guix repl) protocol."
                       (build-locally? #t)
                       (system (%current-system))
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket")
+                      (socket-name (%daemon-socket-uri))
                       (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

bug#36957: [PATCH 5/5] remote: Use (%daemon-socket-uri) rather than hard-coded path.

[Christopher Lemmer Webber]

Merged and pushed!

Now to mark all the other issues as done too...

[bug#36957] [PATCH 1/5] machine: Allow non-root users to deploy.

[Ricardo Wurmus]

Hi Jakob,

> * doc/guix.texi (Invoking guix deploy): Add section describing
> prerequisites for deploying as a non-root user.
> * guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command'
> argument.
> (%remote-eval): New optional 'become-command' argument.
> (remote-eval): New 'become-command' keyword argument.
> * guix/ssh.scm (remote-inferior): New optional 'become-command'
> argument.  
> (inferior-remote-eval): New optional 'become-command' argument.
> (remote-authorize-signing-key): New optional 'become-command' argument.
> * gnu/machine/ssh.scm (machine-become-command): New variable.
> (managed-host-remote-eval): Invoke 'remote-eval' with the
> '#:become-command' keyword.
> (deploy-managed-host): Invoke 'remote-authorize-signing-key' with the
> '#:become-command' keyword.
[…]
> -(define (%remote-eval lowered session)
> +  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
> +    (when (eof-object? (peek-char pipe))
> +      (raise (condition
> +              (&message
> +               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
> +                                repl-command))))))
> +    pipe))

This leads to a compile warning because G_ isn’t available.

-- 
Ricardo

[bug#36957] [PATCH 1/5] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 231 bytes --]

Hi Ricardo,

Ricardo Wurmus <rekado@elephly.net> writes:

> This leads to a compile warning because G_ isn’t available.

Thanks! Surprised I missed that. I've submitted a patch importing '(guix
i18n)'.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36957] [PATCH v3] machine: Allow non-root users to deploy.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 10524 bytes --]

* doc/guix.texi (Invoking guix deploy): Add section describing
prerequisites for deploying as a non-root user.
* guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command'
argument.
(%remote-eval): New optional 'become-command' argument.
(remote-eval): New 'become-command' keyword argument.

* guix/ssh.scm (remote-inferior): New optional 'become-command'
argument. 
(inferior-remote-eval): New optional 'become-command' argument.
(remote-authorize-signing-key): New optional 'become-command' argument.
* gnu/machine/ssh.scm (machine-become-command): New variable.
(managed-host-remote-eval): Invoke 'remote-eval' with the
'#:become-command' keyword.
(deploy-managed-host): Invoke 'remote-authorize-signing-key' with the
'#:become-command' keyword.
---
 doc/guix.texi       | 10 ++++++++
 gnu/machine/ssh.scm | 12 ++++++++-
 guix/remote.scm     | 60 ++++++++++++++++++++++++++++-----------------
 guix/ssh.scm        | 25 +++++++++++++------
 4 files changed, 77 insertions(+), 30 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 734206a4b2..1478749d7d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25514,6 +25514,7 @@ evaluates to.  As an example, @var{file} might contain a definition like this:
        (environment managed-host-environment-type)
        (configuration (machine-ssh-configuration
                        (host-name "localhost")
+                       (user "alice")
                        (identity "./id_rsa")
                        (port 2222)))))
 @end example
@@ -25546,6 +25547,15 @@ accepts store items it receives from the coordinator:
 # guix archive --authorize < coordinator-public-key.txt
 @end example
 
+@code{user}, in this example, specifies the name of the user account to log in
+as to perform the deployment.  Its default value is @code{root}, but root
+login over SSH may be forbidden in some cases.  To work around this,
+@command{guix deploy} can log in as an unprivileged user and employ
+@code{sudo} to escalate privileges.  This will only work if @code{sudo} is
+currently installed on the remote and can be invoked non-interactively as
+@code{user}.  That is: the line in @code{sudoers} granting @code{user} the
+ability to use @code{sudo} must contain the @code{NOPASSWD} tag.
+
 @deftp {Data Type} machine
 This is the data type representing a single machine in a heterogeneous Guix
 deployment.
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index ba3e33c922..aba98f8de5 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -99,6 +99,14 @@ one from the configuration's parameters if one was not provided."
 ;;; Remote evaluation.
 ;;;
 
+(define (machine-become-command machine)
+  "Return as a list of strings the program and arguments necessary to run a
+shell command with escalated privileges for MACHINE's configuration."
+  (if (string= "root" (machine-ssh-configuration-user
+                       (machine-configuration machine)))
+      '()
+      '("/run/setuid-programs/sudo" "-n" "--")))
+
 (define (managed-host-remote-eval machine exp)
   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 an environment type of 'managed-host."
@@ -106,7 +114,9 @@ an environment type of 'managed-host."
   (remote-eval exp (machine-ssh-session machine)
                #:build-locally?
                (machine-ssh-configuration-build-locally?
-                (machine-configuration machine))))
+                (machine-configuration machine))
+               #:become-command
+               (machine-become-command machine)))
 
 \f
 ;;;
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..b0b6afba93 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (remote-eval))
 
@@ -40,29 +42,41 @@
 ;;;
 ;;; Code:
 
-(define (remote-pipe-for-gexp lowered session)
-  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
   (define shell-quote
     (compose object->string object->string))
 
-  (apply open-remote-pipe* session OPEN_READ
-         (string-append (derivation-input-output-path
-                         (lowered-gexp-guile lowered))
-                        "/bin/guile")
-         "--no-auto-compile"
-         (append (append-map (lambda (directory)
-                               `("-L" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 (append-map (lambda (directory)
-                               `("-C" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 `("-c"
-                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+  (define repl-command
+    (append (or become-command '())
+            (list
+             (string-append (derivation-input-output-path
+                             (lowered-gexp-guile lowered))
+                            "/bin/guile")
+             "--no-auto-compile")
+            (append-map (lambda (directory)
+                          `("-L" ,directory))
+                        (lowered-gexp-load-path lowered))
+            (append-map (lambda (directory)
+                          `("-C" ,directory))
+                        (lowered-gexp-load-path lowered))
+            `("-c"
+              ,(shell-quote (lowered-gexp-sexp lowered)))))
 
-(define (%remote-eval lowered session)
+  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
+    pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
-  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
          (result (read-repl-response pipe)))
     (close-port pipe)
     result))
@@ -90,12 +104,14 @@ result to the current output port using the (guix repl) protocol."
                       #:key
                       (build-locally? #t)
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket"))
+                      (socket-name "/var/guix/daemon-socket/socket")
+                      (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 the remote store afterwards; otherwise, dependencies are built directly on the
-remote store."
+remote store.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
   (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
                                            #:module-path %load-path))
                       (remote -> (connect-to-remote-daemon session
@@ -115,7 +131,7 @@ remote store."
             (built-derivations inputs)
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (close-connection remote))
-            (return (%remote-eval lowered session))))
+            (return (%remote-eval lowered session become-command))))
         (let ((to-send (append (map (compose derivation-file-name
                                              derivation-input-derivation)
                                     inputs)
@@ -124,4 +140,4 @@ remote store."
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (build-derivations remote inputs))
             (return (close-connection remote))
-            (return (%remote-eval lowered session)))))))
+            (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ede00133c8..0f65f9e65b 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -97,16 +97,27 @@ specifies; otherwise use them.  Throw an error on failure."
                 (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                  host (get-error session))))))))))
 
-(define (remote-inferior session)
-  "Return a remote inferior for the given SESSION."
-  (let ((pipe (open-remote-pipe* session OPEN_BOTH
-                                 "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+  (let* ((repl-command (append (or become-command '())
+                               '("guix" "repl" "-t" "machine")))
+         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
+    ;; process does succeed. This doesn't reflect the documentation, so it's
+    ;; possible that it's a bug in guile-ssh.
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
     (port->inferior pipe)))
 
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
   "Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
-  (let ((inferior (remote-inferior session)))
+right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+  (let ((inferior (remote-inferior session become-command)))
     (dynamic-wind
       (const #t)
       (lambda ()
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]