services: guix: Add 'set-http-proxy' action.

Fixes <https://bugs.gnu.org/25569>.
Reported by Divan Santana <divan@santanas.co.za>.

* gnu/services/base.scm (shepherd-set-http-proxy-action): New procedure.
(guix-shepherd-service): Add 'actions' field.  Change 'start' to a
lambda; check the value of the "http_proxy" environment variable and
add "http_proxy" and "https_proxy" to #:environment-variables as a
function of that.
* gnu/tests/base.scm (run-basic-test)["guix-daemon set-http-proxy
action", "guix-daemon set-http-proxy action, clear"]: New tests.
* doc/guix.texi (Base Services): Document it.

2 files changed, 89 insertions, 39 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index f802005e3c..cb556e87bc 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1640,6 +1640,30 @@ archive' public keys, with GUIX."
 (define %default-guix-configuration
   (guix-configuration))
 
+(define shepherd-set-http-proxy-action
+  ;; Shepherd action to change the HTTP(S) proxy.
+  (shepherd-action
+   (name 'set-http-proxy)
+   (documentation
+    "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
+   (procedure #~(lambda* (_ #:optional proxy)
+                  (let ((environment (environ)))
+                    ;; A bit of a hack: communicate PROXY to the 'start'
+                    ;; method via environment variables.
+                    (if proxy
+                        (begin
+                          (format #t "changing HTTP/HTTPS \
+proxy of 'guix-daemon' to ~s...~%"
+                                  proxy)
+                          (setenv "http_proxy" proxy))
+                        (begin
+                          (format #t "clearing HTTP/HTTPS \
+proxy of 'guix-daemon'...~%")
+                          (unsetenv "http_proxy")))
+                    (action 'guix-daemon 'restart)
+                    (environ environment)
+                    #t)))))
+
 (define (guix-shepherd-service config)
   "Return a <shepherd-service> for the Guix daemon service with CONFIG."
   (match-record config <guix-configuration>
@@ -1651,47 +1675,58 @@ archive' public keys, with GUIX."
            (documentation "Run the Guix daemon.")
            (provision '(guix-daemon))
            (requirement '(user-processes))
+           (actions (list shepherd-set-http-proxy-action))
            (modules '((srfi srfi-1)))
            (start
-            #~(make-forkexec-constructor
-               (cons* #$(file-append guix "/bin/guix-daemon")
-                      "--build-users-group" #$build-group
-                      "--max-silent-time" #$(number->string max-silent-time)
-                      "--timeout" #$(number->string timeout)
-                      "--log-compression" #$(symbol->string log-compression)
-                      #$@(if use-substitutes?
-                             '()
-                             '("--no-substitutes"))
-                      "--substitute-urls" #$(string-join substitute-urls)
-                      #$@extra-options
-
-                      ;; Add CHROOT-DIRECTORIES and all their dependencies (if
-                      ;; these are store items) to the chroot.
-                      (append-map (lambda (file)
-                                    (append-map (lambda (directory)
-                                                  (list "--chroot-directory"
-                                                        directory))
-                                                (call-with-input-file file
-                                                  read)))
-                                  '#$(map references-file chroot-directories)))
-
-               #:environment-variables
-               (list #$@(if http-proxy
-                            (list (string-append "http_proxy=" http-proxy))
-                            '())
-                     #$@(if tmpdir
-                            (list (string-append "TMPDIR=" tmpdir))
-                            '())
-
-                     ;; Make sure we run in a UTF-8 locale so that 'guix
-                     ;; offload' correctly restores nars that contain UTF-8
-                     ;; file names such as 'nss-certs'.  See
-                     ;; <https://bugs.gnu.org/32942>.
-                     (string-append "GUIX_LOCPATH="
-                                    #$glibc-utf8-locales "/lib/locale")
-                     "LC_ALL=en_US.utf8")
-
-               #:log-file #$log-file))
+            #~(lambda _
+                (define proxy
+                  ;; HTTP/HTTPS proxy.  The 'http_proxy' variable is set by
+                  ;; the 'set-http-proxy' action.
+                  (or (getenv "http_proxy") #$http-proxy))
+
+                (fork+exec-command
+                 (cons* #$(file-append guix "/bin/guix-daemon")
+                        "--build-users-group" #$build-group
+                        "--max-silent-time" #$(number->string max-silent-time)
+                        "--timeout" #$(number->string timeout)
+                        "--log-compression" #$(symbol->string log-compression)
+                        #$@(if use-substitutes?
+                               '()
+                               '("--no-substitutes"))
+                        "--substitute-urls" #$(string-join substitute-urls)
+                        #$@extra-options
+
+                        ;; Add CHROOT-DIRECTORIES and all their dependencies
+                        ;; (if these are store items) to the chroot.
+                        (append-map (lambda (file)
+                                      (append-map (lambda (directory)
+                                                    (list "--chroot-directory"
+                                                          directory))
+                                                  (call-with-input-file file
+                                                    read)))
+                                    '#$(map references-file
+                                            chroot-directories)))
+
+                 #:environment-variables
+                 (append (list #$@(if tmpdir
+                                      (list (string-append "TMPDIR=" tmpdir))
+                                      '())
+
+                               ;; Make sure we run in a UTF-8 locale so that
+                               ;; 'guix offload' correctly restores nars that
+                               ;; contain UTF-8 file names such as
+                               ;; 'nss-certs'.  See
+                               ;; <https://bugs.gnu.org/32942>.
+                               (string-append "GUIX_LOCPATH="
+                                              #$glibc-utf8-locales
+                                              "/lib/locale")
+                               "LC_ALL=en_US.utf8")
+                         (if proxy
+                             (list (string-append "http_proxy=" proxy)
+                                   (string-append "https_proxy=" proxy))
+                             '()))
+
+                 #:log-file #$log-file)))
            (stop #~(make-kill-destructor))))))
 
 (define (guix-accounts config)
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index fe63cecbd0..086d2a133f 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -459,6 +459,21 @@ info --version")
             (marionette-eval '(readlink "/var/guix/gcroots/profiles")
                              marionette))
 
+          (test-equal "guix-daemon set-http-proxy action"
+            '(#t)                                 ;one value, #t
+            (marionette-eval '(with-shepherd-action 'guix-daemon
+                                  ('set-http-proxy "http://localhost:8118")
+                                  result
+                                result)
+                             marionette))
+
+          (test-equal "guix-daemon set-http-proxy action, clear"
+            '(#t)                                 ;one value, #t
+            (marionette-eval '(with-shepherd-action 'guix-daemon
+                                  ('set-http-proxy)
+                                  result
+                                result)
+                             marionette))
 
           (test-assert "screendump"
             (begin