[bug#62848] [PATCH v2] environment: Add --remote option and emacsclient-eshell backend.

[Antero Mejr via Guix-patches via <guix-patches@gnu.org>]

* guix/scripts/environment.scm (launch-environment/eshell): New procedure.
(%remote-backends): New variable.
(guix-environment*): Add logic for remote backend switching.
(launch-envrionment)[white-list]: Change keyword argument name to
'allow-list'.
(launch-environment/fork)[white-list]: Change keyword argument name to
'allow-list'.
(%options): Add --remote and --list-remote-backends options.
(show-environment-options-help): Add help text for new options.
* guix/profiles.scm (load-profile)[getenv-proc, setenv-proc, unsetenv-proc]:
New optional keyword arguments.
(load-profile)[white-list]: Change keyword argument name to 'allow-list'.
(purify-environment)[white-list-regexps]: Change argument name to
'allow-list-regexps'.
(purify-environment)[unsetenv-proc]: New argument.
* guix/build/emacs-utils.scm (%emacsclient): New parameter.
(emacsclient-batch-script): New procedure.
* doc/guix.texi(Invoking guix shell): Document --remote and
--list-remote-backends options.
* tests/build-emacs-utils.scm(emacsclient-batch-script): New test.
* tests/profiles.scm(load-profile): Change 'white-list' keyword argument to
'allow-list'.
---
With requested changes from Maxim's review:
Update white-list/allow-list terminology throughout.
Always check for errors when invoking emacsclient.
Simplify emacsclient invocation code by using the
(guix build emacs-utils) module.
Add new test to build-emacs-utils.scm for testing emacsclient.

 doc/guix.texi                |  17 ++++++
 guix/build/emacs-utils.scm   |  21 +++++++
 guix/profiles.scm            |  42 ++++++++------
 guix/scripts/environment.scm | 106 ++++++++++++++++++++++++++++-------
 tests/build-emacs-utils.scm  |  12 +++-
 tests/profiles.scm           |   2 +-
 6 files changed, 160 insertions(+), 40 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 9f06f1c325..92a0d99db7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6474,6 +6474,23 @@ Invoking guix shell
 @itemx -s @var{system}
 Attempt to build for @var{system}---e.g., @code{i686-linux}.
 
+@item --remote=@var{backend}[=@var{args}]
+Create an environment over a remote connection using @var{backend},
+optionally passing @var{args} to the backend.
+
+This option causes the @option{--container} option to be ignored.
+
+When @var{backend} is @code{emacsclient-eshell}, a new eshell buffer
+with the Guix environment will be opened.  An Emacs server must already
+be running, and the @code{emacsclient} program must be available.  Due
+to the way @code{eshell} handles commands, the @var{command} argument,
+if specified, will run in the initial @code{eshell} environment instead
+of the Guix @code{eshell} environment.
+
+@item --list-remote-backends
+Display the @var{backend} options for @code{guix shell --remote=BACKEND}
+and exit.
+
 @item --container
 @itemx -C
 @cindex container
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index 8e12b5b6d4..e56e230efb 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -28,10 +28,12 @@ (define-module (guix build emacs-utils)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (%emacs
+            %emacsclient
             emacs-batch-eval
             emacs-batch-edit-file
             emacs-batch-disable-compilation
             emacs-batch-script
+            emacsclient-batch-script
 
             emacs-batch-error?
             emacs-batch-error-message
@@ -57,6 +59,10 @@ (define %emacs
   ;; The `emacs' command.
   (make-parameter "emacs"))
 
+(define %emacsclient
+  ;; A list starting with the `emacsclient' command, plus optional arguments.
+  (make-parameter '("emacsclient")))
+
 (define (expr->string expr)
   "Converts EXPR, an expression, into a string."
   (if (string? expr)
@@ -107,6 +113,21 @@ (define (emacs-batch-script expr)
                          (message (read-string (car error-pipe)))))))
     output))
 
+(define (emacsclient-batch-script expr)
+  "Send the Elisp code EXPR to Emacs via emacsclient and return output."
+  (let* ((error-pipe (pipe))
+         (port (parameterize ((current-error-port (cdr error-pipe)))
+                 (apply open-pipe* OPEN_READ
+                        (car (%emacsclient)) "--eval" (expr->string expr)
+                        (cdr (%emacsclient)))))
+         (output (read-string port))
+         (status (close-pipe port)))
+    (close-port (cdr error-pipe))
+    (unless (zero? status)
+      (raise (condition (&emacs-batch-error
+                         (message (read-string (car error-pipe)))))))
+    (string-trim-both output (char-set-adjoin char-set:whitespace #\"))))
+
 (define (emacs-generate-autoloads name directory)
   "Generate autoloads for Emacs package NAME placed in DIRECTORY."
   (let* ((file (string-append directory "/" name "-autoloads.el"))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 5d2fb8dc64..eca2b82cb3 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -2103,41 +2103,47 @@ (define* (profile-search-paths profile
                          (list profile) getenv))
 
 (define %precious-variables
-  ;; Environment variables in the default 'load-profile' white list.
+  ;; Environment variables in the default 'load-profile' allow list.
   '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
 
-(define (purify-environment white-list white-list-regexps)
+(define (purify-environment allow-list allow-list-regexps unsetenv-proc)
   "Unset all environment variables except those that match the regexps in
-WHITE-LIST-REGEXPS and those listed in WHITE-LIST."
-  (for-each unsetenv
+ALLOW-LIST-REGEXPS and those listed in ALLOW-LIST."
+  (for-each unsetenv-proc
             (remove (lambda (variable)
-                      (or (member variable white-list)
+                      (or (member variable allow-list)
                           (find (cut regexp-exec <> variable)
-                                white-list-regexps)))
+                                allow-list-regexps)))
                     (match (get-environment-variables)
                       (((names . _) ...)
                        names)))))
 
 (define* (load-profile profile
                        #:optional (manifest (profile-manifest profile))
-                       #:key pure? (white-list-regexps '())
-                       (white-list %precious-variables))
+                       #:key pure? (allow-list-regexps '())
+                       (allow-list %precious-variables)
+                       (getenv-proc getenv) (setenv-proc setenv)
+                       (unsetenv-proc unsetenv))
   "Set the environment variables specified by MANIFEST for PROFILE.  When
 PURE? is #t, unset the variables in the current environment except those that
-match the regexps in WHITE-LIST-REGEXPS and those listed in WHITE-LIST.
+match the regexps in ALLOW-LIST-REGEXPS and those listed in ALLOW-LIST.
 Otherwise, augment existing environment variables with additional search
-paths."
+paths.
+GETENV-PROC is a one-argument procedure that returns an env var value.
+SETENV-PROC is a two-argument procedure the sets environment variables.
+UNSETENV-PROC is a one-argument procedure that unsets environment variables.
+Change those procedures to load a profile over a remote connection."
   (when pure?
-    (purify-environment white-list white-list-regexps))
+    (purify-environment allow-list allow-list-regexps unsetenv-proc))
   (for-each (match-lambda
               ((($ <search-path-specification> variable _ separator) . value)
-               (let ((current (getenv variable)))
-                 (setenv variable
-                         (if (and current (not pure?))
-                             (if separator
-                                 (string-append value separator current)
-                                 value)
-                             value)))))
+               (let ((current (getenv-proc variable)))
+                 (setenv-proc variable
+                              (if (and current (not pure?))
+                                  (if separator
+                                      (string-append value separator current)
+                                      value)
+                                  value)))))
             (profile-search-paths profile manifest)))
 
 (define (profile-regexp profile)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 6ae3b11e39..fa033dc0ae 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
 ;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com>
+;;; Copyright © 2023, Antero Mejr <antero@mailbox.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (guix scripts environment)
   #:use-module (guix profiles)
   #:use-module (guix search-paths)
   #:use-module (guix build utils)
+  #:use-module (guix build emacs-utils)
   #:use-module (guix monads)
   #:use-module ((guix gexp) #:select (lower-object))
   #:autoload   (guix describe) (current-profile current-channels)
@@ -72,6 +74,9 @@ (define-module (guix scripts environment)
 (define %default-shell
   (or (getenv "SHELL") "/bin/sh"))
 
+(define %remote-backends
+  '("emacsclient-eshell"))
+
 (define* (show-search-paths profile manifest #:key pure?)
   "Display the search paths of MANIFEST applied to PROFILE.  When PURE? is #t,
 do not augment existing environment variables with additional search paths."
@@ -104,6 +109,13 @@ (define (show-environment-options-help)
   (display (G_ "
   -r, --root=FILE        make FILE a symlink to the result, and register it
                          as a garbage collector root"))
+  (display (G_ "
+      --remote=BACKEND[=ARGS]
+                        create environment over a remote connection by
+                        passing ARGS to BACKEND"))
+  (display (G_ "
+      --list-remote-backends
+                         list available remote backends and exit"))
   (display (G_ "
   -C, --container        run command within an isolated container"))
   (display (G_ "
@@ -287,6 +299,13 @@ (define %options
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
+         (option '("remote") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'remote arg result)))
+         (option '("list-remote-backends") #f #f
+                 (lambda args
+                   (display (string-join %remote-backends "\n" 'suffix))
+                   (exit 0)))
 
          (append %transformation-options
                  %standard-build-options
@@ -485,18 +504,18 @@ (define exit/status (compose exit status->exit-code))
 (define primitive-exit/status (compose primitive-exit status->exit-code))
 
 (define* (launch-environment command profile manifest
-                             #:key pure? (white-list '())
+                             #:key pure? (allow-list '())
                              emulate-fhs?)
   "Load the environment of PROFILE, which corresponds to MANIFEST, and execute
 COMMAND.  When PURE?, pre-existing environment variables are cleared before
-setting the new ones, except those matching the regexps in WHITE-LIST.  When
+setting the new ones, except those matching the regexps in ALLOW-LIST.  When
 EMULATE-FHS?, first set up an FHS environment with $PATH and generate the LD
 cache."
   ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
   ;; application works.
   (sigaction SIGINT SIG_DFL)
   (load-profile profile manifest
-                #:pure? pure? #:white-list-regexps white-list)
+                #:pure? pure? #:allow-list-regexps allow-list)
 
   ;; Give users a way to know that they're in 'guix environment', so they can
   ;; adjust 'PS1' accordingly, for instance.  Set it to PROFILE so users can
@@ -706,24 +725,53 @@ (define (suggest-command-name profile command)
                           closest))))))))
 
 (define* (launch-environment/fork command profile manifest
-                                  #:key pure? (white-list '()))
+                                  #:key pure? (allow-list '()))
   "Run COMMAND in a new process with an environment containing PROFILE, with
 the search paths specified by MANIFEST.  When PURE?, pre-existing environment
 variables are cleared before setting the new ones, except those matching the
-regexps in WHITE-LIST."
+regexps in ALLOW-LIST."
   (match (primitive-fork)
     (0 (launch-environment command profile manifest
                            #:pure? pure?
-                           #:white-list white-list))
+                           #:allow-list allow-list))
     (pid (match (waitpid pid)
            ((_ . status)
             status)))))
 
+(define* (launch-environment/eshell args command profile manifest
+                                    #:key pure? (allow-list '()))
+  "Create an new eshell buffer with an environment containing PROFILE,
+with the search paths specified by MANIFEST.  When PURE?, pre-existing
+environment variables are cleared before setting the new ones, except those
+matching the regexps in ALLOW-LIST."
+
+  (parameterize ((%emacsclient (cons "emacsclient" args)))
+    (let* ((buf (emacsclient-batch-script '(buffer-name (eshell t))))
+           (ec-buf
+            (lambda (cmd)
+              (emacsclient-batch-script `(with-current-buffer ,buf ,cmd)))))
+    (load-profile
+     profile manifest #:pure? pure? #:allow-list-regexps allow-list
+     #:setenv-proc (lambda (var val)
+                     (ec-buf (if (string=? var "PATH")
+                                 ;; TODO: TRAMP support?
+                                 `(eshell-set-path ,val)
+                                 `(setenv ,var ,val))))
+     #:unsetenv-proc (lambda (var)
+                       (ec-buf `(setenv ,var))))
+    (match command
+      ((program . args)
+       (begin (ec-buf
+               `(eshell-command
+                 ,(string-append program " " (string-join args))))
+              (ec-buf '(kill-buffer))))
+      (else #t)))))
+
 (define* (launch-environment/container #:key command bash user user-mappings
                                        profile manifest link-profile? network?
                                        map-cwd? emulate-fhs? nesting?
                                        (setup-hook #f)
-                                       (symlinks '()) (white-list '()))
+                                       (symlinks '()) (allow-list '()))
   "Run COMMAND within a container that features the software in PROFILE.
 Environment variables are set according to the search paths of MANIFEST.  The
 global shell is BASH, a file name for a GNU Bash binary in the store.  When
@@ -748,7 +796,7 @@ (define* (launch-environment/container #:key command bash user user-mappings
 added to the container.
 
 Preserve environment variables whose name matches the one of the regexps in
-WHILE-LIST."
+ALLOW-LIST."
   (define (optional-mapping->fs mapping)
     (and (file-exists? (file-system-mapping-source mapping))
          (file-system-mapping->bind-mount mapping)))
@@ -818,7 +866,7 @@ (define* (launch-environment/container #:key command bash user user-mappings
             (environ  (filter (match-lambda
                                 ((variable . value)
                                  (find (cut regexp-exec <> variable)
-                                       white-list)))
+                                       allow-list)))
                               (get-environment-variables)))
             ;; Bind-mount all requisite store items, user-specified mappings,
             ;; /bin/sh, the current working directory, and possibly networking
@@ -931,7 +979,7 @@ (define* (launch-environment/container #:key command bash user user-mappings
                        (override-user-dir user home cwd)
                        home-dir))
 
-            ;; Set environment variables that match WHITE-LIST.
+            ;; Set environment variables that match ALLOW-LIST.
             (for-each (match-lambda
                         ((variable . value)
                          (setenv variable value)))
@@ -1081,16 +1129,19 @@ (define (guix-environment* opts)
          (bootstrap?   (assoc-ref opts 'bootstrap?))
          (system       (assoc-ref opts 'system))
          (profile      (assoc-ref opts 'profile))
+         (remote (string-split (assoc-ref opts 'remote) #\=))
          (command  (or (assoc-ref opts 'exec)
                        ;; Spawn a shell if the user didn't specify
                        ;; anything in particular.
-                       (if container?
-                           ;; The user's shell is likely not available
-                           ;; within the container.
-                           '("/bin/sh")
-                           (list %default-shell))))
+                       (cond (container?
+                              ;; The user's shell is likely not available
+                              ;; within the container.
+                              '("/bin/sh"))
+                             ;; For remote, let the backend decide.
+                             (remote '())
+                             (else (list %default-shell)))))
          (mappings   (pick-all opts 'file-system-mapping))
-         (white-list (pick-all opts 'inherit-regexp)))
+         (allow-list (pick-all opts 'inherit-regexp)))
 
     (define store-needed?
       ;; Whether connecting to the daemon is needed.
@@ -1129,6 +1180,10 @@ (define (guix-environment* opts)
       (when (pair? symlinks)
         (leave (G_ "'--symlink' cannot be used without '--container'~%"))))
 
+    (when (and remote (not (member (car remote) %remote-backends)))
+      (leave
+       (G_ "Invalid remote backend, see --list-remote-backends for options.~%'")))
+
     (with-store/maybe store
       (with-status-verbosity (assoc-ref opts 'verbosity)
         (define manifest-from-opts
@@ -1182,15 +1237,26 @@ (define (guix-environment* opts)
 
                 (mwhen (assoc-ref opts 'check?)
                   (return
-                   (if container?
+                   (if (or container? remote)
                        (warning (G_ "'--check' is unnecessary \
-when using '--container'; doing nothing~%"))
+when using '--container' or '--remote'; doing nothing~%"))
                        (validate-child-shell-environment profile manifest))))
 
                 (cond
                  ((assoc-ref opts 'search-paths)
                   (show-search-paths profile manifest #:pure? pure?)
                   (return #t))
+                 (remote
+                  (match (car remote)
+                    ("emacsclient-eshell"
+                     (return
+                      (launch-environment/eshell
+                       (match (cdr remote)
+                         ((args) (string-split args #\space))
+                         (_ '()))
+                       command profile manifest
+                       #:allow-list allow-list
+                       #:pure? pure?)))))
                  (container?
                   (let ((bash-binary
                          (if bootstrap?
@@ -1203,7 +1269,7 @@ (define (guix-environment* opts)
                                                   #:user-mappings mappings
                                                   #:profile profile
                                                   #:manifest manifest
-                                                  #:white-list white-list
+                                                  #:allow-list allow-list
                                                   #:link-profile? link-prof?
                                                   #:network? network?
                                                   #:map-cwd? (not no-cwd?)
@@ -1218,7 +1284,7 @@ (define (guix-environment* opts)
                   (return
                    (exit/status
                     (launch-environment/fork command profile manifest
-                                             #:white-list white-list
+                                             #:allow-list allow-list
                                              #:pure? pure?)))))))))))))
 
 ;;; Local Variables:
diff --git a/tests/build-emacs-utils.scm b/tests/build-emacs-utils.scm
index 4e851ed959..6b845b93b9 100644
--- a/tests/build-emacs-utils.scm
+++ b/tests/build-emacs-utils.scm
@@ -29,12 +29,22 @@ (define-module (test build-emacs-utils)
 
 (test-begin "build-emacs-utils")
 ;; Only run the following tests if emacs is present.
-(test-skip (if (which "emacs") 0 5))
+(test-skip (if (which "emacs") 0 6))
 
 (test-equal "emacs-batch-script: print foo from emacs"
   "foo"
   (emacs-batch-script '(princ "foo")))
 
+;; Note: If this test fails, subsequent runs might end up in a bad state.
+;; Running "emacsclient -s test -e '(kill-emacs)'" should fix it.
+(test-equal "emacsclient-batch-script: print foo from emacs via emacsclient"
+  "foo"
+  (begin (invoke (%emacs) "--quick" "--daemon=test")
+         (parameterize ((%emacsclient '("emacsclient" "-s" "test")))
+           (let ((out (emacsclient-batch-script '(princ "foo"))))
+             (emacsclient-batch-script '(kill-emacs))
+             out))))
+
 (test-assert "emacs-batch-script: raise &emacs-batch-error on failure"
   (guard (c ((emacs-batch-error? c)
              ;; The error message format changed between Emacs 27 and Emacs
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 9c419ada93..1e134f5105 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -367,7 +367,7 @@ (define glibc
                                        (getenv "PATH"))
                        (getenv "GUILE_LOAD_PATH")))
                  (with-environment-excursion
-                  (load-profile profile #:pure? #t #:white-list '())
+                  (load-profile profile #:pure? #t #:allow-list '())
                   (equal? (list (string-append "PATH=" bindir))
                           (environ)))))))
 

base-commit: 220759226e93d76d8d80058f69f9d8b29714bbde
-- 
2.41.0