Merge branch 'master' into staging

4 files changed, 149 insertions, 40 deletions

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 1707622c4f..27478eabc0 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 David Thompson <davet@gnu.org>
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,18 +24,21 @@
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (guix store)
+  #:use-module (guix gexp)
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix grafts)
-  #:use-module (guix status)
+  #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:export (guix-deploy))
 
 ;;; Commentary:
@@ -58,6 +61,9 @@ Perform the deployment specified by FILE.\n"))
   -V, --version          display version information and exit"))
   (newline)
   (display (G_ "
+  -x, --execute          execute the following command on all the machines"))
+  (newline)
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (show-bug-report-information))
 
@@ -70,6 +76,9 @@ Perform the deployment specified by FILE.\n"))
                  (lambda args
                    (show-version-and-exit "guix deploy")))
 
+         (option '(#\x "execute") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'execute-command? #t result)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -152,6 +161,74 @@ Perform the deployment specified by FILE.\n"))
     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
 
+(define (invoke-command store machine command)
+  "Invoke COMMAND, a list of strings, on MACHINE.  Display its output (if any)
+and its error code if it's non-zero.  Return true if COMMAND succeeded, false
+otherwise."
+  (define invocation
+    #~(begin
+        (use-modules (ice-9 match)
+                     (ice-9 rdelim)
+                     (srfi srfi-11))
+
+        (define (spawn . command)
+          ;; Spawn COMMAND; return its PID and an input port to read its
+          ;; standard output and standard error.
+          (match (pipe)
+            ((input . output)
+             (match (pipe)
+               ((input .  output)
+                (match (primitive-fork)
+                  (0
+                   (dynamic-wind
+                     (const #t)
+                     (lambda ()
+                       (close-port input)
+                       (dup2 (fileno output) 1)
+                       (dup2 (fileno output) 2)
+                       (apply execlp (car command) command))
+                     (lambda ()
+                       (primitive-exit 127))))
+                  (pid
+                   (close-port output)
+                   (values pid input))))))))
+
+        ;; XXX: 'open-pipe*' is unsuitable here because it does not capture
+        ;; stderr, so roll our own.
+        (let-values (((pid pipe) (spawn #$@command)))
+          (let loop ((lines '()))
+            (match (read-line pipe 'concat)
+              ((? eof-object?)
+               (list (cdr (waitpid pid))
+                     (string-concatenate-reverse lines)))
+              (line
+               (loop (cons line lines))))))))
+
+  (match (run-with-store store
+           (machine-remote-eval machine invocation))
+    ((code output)
+     (match code
+       ((? zero?)
+        (info (G_ "~a: command succeeded~%")
+              (machine-display-name machine)))
+       ((= status:exit-val code)
+        (report-error (G_ "~a: command exited with code ~a~%")
+                      (machine-display-name machine) code))
+       ((= status:stop-sig signal)
+        (report-error (G_ "~a: command stopped with signal ~a~%")
+                      signal))
+       ((= status:term-sig signal)
+        (report-error (G_ "~a: command terminated with signal ~a~%")
+                      signal)))
+
+     (unless (string-null? output)
+       (info (G_ "command output on ~a:~%")
+             (machine-display-name machine))
+       (display output)
+       (newline))
+
+     (zero? code))))
+
 
 (define-command (guix-deploy . args)
   (synopsis "deploy operating systems on a set of machines")
@@ -159,14 +236,17 @@ Perform the deployment specified by FILE.\n"))
     (alist-cons 'file arg result))
 
   (with-error-handling
-    (let* ((opts (parse-command-line args %options (list %default-options)
+    (let* ((args command (break (cut string=? "--" <>) args))
+           (opts (parse-command-line args %options (list %default-options)
                                      #:argument-handler handle-argument))
            (file (assq-ref opts 'file))
-           (machines (and file (load-source-file file))))
+           (machines (and file (load-source-file file)))
+           (execute-command? (assoc-ref opts 'execute-command?)))
       (unless file
         (leave (G_ "missing deployment file argument~%")))
 
-      (show-what-to-deploy machines)
+      (when (and (pair? command) (not execute-command?))
+        (leave (G_ "'--' was used by '-x' was not specified~%")))
 
       (with-status-verbosity (assoc-ref opts 'verbosity)
         (with-store store
@@ -176,6 +256,21 @@ Perform the deployment specified by FILE.\n"))
                                               #:verbosity
                                               (assoc-ref opts 'verbosity))
             (parameterize ((%graft? (assq-ref opts 'graft?)))
-              (map/accumulate-builds store
-                                     (cut deploy-machine* store <>)
-                                     machines))))))))
+              (if execute-command?
+                  (match command
+                    (("--" command ..1)
+                     ;; Exit with zero unless COMMAND failed on one or more
+                     ;; machines.
+                     (exit
+                      (fold (lambda (machine result)
+                              (and (invoke-command store machine command)
+                                   result))
+                            #t
+                            machines)))
+                    (_
+                     (leave (G_ "'-x' specified but no command given~%"))))
+                  (begin
+                    (show-what-to-deploy machines)
+                    (map/accumulate-builds store
+                                           (cut deploy-machine* store <>)
+                                           machines))))))))))
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 2312e4d313..837fd96361 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -36,7 +36,8 @@
   #:use-module (guix scripts)
   #:use-module (guix scripts package)
   #:use-module (guix scripts build)
-  #:use-module (guix scripts system search)
+  #:autoload   (guix scripts system search) (service-type->recutils)
+  #:use-module (guix scripts system reconfigure)
   #:autoload   (guix scripts pull) (channel-commit-hyperlink)
   #:use-module (guix scripts home import)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -92,6 +93,9 @@ Some ACTIONS support additional ARGS.\n"))
   -e, --expression=EXPR  consider the home-environment EXPR evaluates to
                          instead of reading FILE, when applicable"))
   (display (G_ "
+      --allow-downgrades for 'reconfigure', allow downgrades to earlier
+                         channel revisions"))
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (newline)
   (display (G_ "
@@ -127,18 +131,23 @@ Some ACTIONS support additional ARGS.\n"))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
+         (option '("allow-downgrades") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'validate-reconfigure
+                               warn-about-backward-reconfigure
+                               result)))
          %standard-build-options))
 
 (define %default-options
-  `((build-mode . ,(build-mode normal))
-    (graft? . #t)
+  `((graft? . #t)
     (substitutes? . #t)
     (offload? . #t)
     (print-build-trace? . #t)
     (print-extended-build-trace? . #t)
     (multiplexed-build-output? . #t)
     (verbosity . #f)                              ;default
-    (debug . 0)))
+    (debug . 0)
+    (validate-reconfigure . ,ensure-forward-reconfigure)))
 
 
 ;;;
@@ -149,12 +158,17 @@ Some ACTIONS support additional ARGS.\n"))
                          #:key
                          dry-run?
                          derivations-only?
-                         use-substitutes?)
+                         use-substitutes?
+                         (validate-reconfigure ensure-forward-reconfigure))
   "Perform ACTION for home environment. "
 
   (define println
     (cut format #t "~a~%" <>))
 
+  (when (eq? action 'reconfigure)
+    (check-forward-update validate-reconfigure
+                          #:current-channels (home-provenance %guix-home)))
+
   (mlet* %store-monad
       ((he-drv   (home-environment-derivation he))
        (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
@@ -237,13 +251,12 @@ resulting from command-line parsing."
           (mbegin %store-monad
             (set-guile-for-build (default-guile))
 
-            (case action
-              (else
-               (perform-action action home-environment
-                               #:dry-run? dry?
-                               #:derivations-only? (assoc-ref opts 'derivations-only?)
-                               #:use-substitutes? (assoc-ref opts 'substitutes?))
-               ))))))
+            (perform-action action home-environment
+                            #:dry-run? dry?
+                            #:derivations-only? (assoc-ref opts 'derivations-only?)
+                            #:use-substitutes? (assoc-ref opts 'substitutes?)
+                            #:validate-reconfigure
+                            (assoc-ref opts 'validate-reconfigure))))))
     (warn-about-disk-space)))
 
 
diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm
index a52cd95c93..b9b12ee43a 100644
--- a/guix/scripts/import/pypi.scm
+++ b/guix/scripts/import/pypi.scm
@@ -79,27 +79,28 @@ Import and convert the PyPI package for PACKAGE-NAME.\n"))
 
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
-                            (('argument . value)
-                             value)
-                            (_ #f))
+                             (('argument . value)
+                              value)
+                             (_ #f))
                            (reverse opts))))
     (match args
       ((spec)
-       (let ((name version (package-name->name+version spec)))
-         (if (assoc-ref opts 'recursive)
-             ;; Recursive import
-             (map (match-lambda
-                    ((and ('package ('name name) . rest) pkg)
-                     `(define-public ,(string->symbol name)
-                        ,pkg))
-                    (_ #f))
-                  (pypi-recursive-import name version))
-             ;; Single import
-             (let ((sexp (pypi->guix-package name #:version version)))
-               (unless sexp
-                 (leave (G_ "failed to download meta-data for package '~a'~%")
-                        name))
-               sexp))))
+       (with-error-handling
+         (let ((name version (package-name->name+version spec)))
+           (if (assoc-ref opts 'recursive)
+               ;; Recursive import
+               (map (match-lambda
+                      ((and ('package ('name name) . rest) pkg)
+                       `(define-public ,(string->symbol name)
+                          ,pkg))
+                      (_ #f))
+                    (pypi-recursive-import name version))
+               ;; Single import
+               (let ((sexp (pypi->guix-package name #:version version)))
+                 (unless sexp
+                   (leave (G_ "failed to download meta-data for package '~a'~%")
+                          name))
+                 sexp)))))
       (()
        (leave (G_ "too few arguments~%")))
       ((many ...)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 414e931c8a..430815902d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -1328,7 +1328,7 @@ argument list and OPTS is the option alist."
                       (x (leave (G_ "wrong number of arguments~%"))))))
        (list-generations pattern)))
     ((describe)
-     (match (generation-number %system-profile)
+     (match (generation-number "/run/current-system" %system-profile)
        (0
         (leave (G_ "no system generation, nothing to describe~%")))
        (generation