Merge branch 'master' into staging

4 files changed, 89 insertions, 27 deletions

diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 22cd75ea0b..589f62da9d 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,7 @@
   #:use-module (gcrypt hash)
   #:use-module (guix base16)
   #:use-module (guix base32)
+  #:autoload   (guix base64) (base64-encode)
   #:use-module ((guix download) #:hide (url-fetch))
   #:use-module ((guix build download)
                 #:select (url-fetch))
@@ -77,19 +78,23 @@
 (define %default-options
   ;; Alist of default option values.
   `((format . ,bytevector->nix-base32-string)
+    (hash-algorithm . ,(hash-algorithm sha256))
     (verify-certificate? . #t)
     (download-proc . ,download-to-store*)))
 
 (define (show-help)
   (display (G_ "Usage: guix download [OPTION] URL
 Download the file at URL to the store or to the given file, and print its
-file name and the hash of its contents.
-
-Supported formats: 'nix-base32' (default), 'base32', and 'base16'
-('hex' and 'hexadecimal' can be used as well).\n"))
+file name and the hash of its contents.\n"))
+  (newline)
+  (display (G_ "\
+Supported formats: 'base64', 'nix-base32' (default), 'base32',
+and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
   (format #t (G_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (G_ "
+  -H, --hash=ALGORITHM   use the given hash ALGORITHM"))
+  (format #t (G_ "
       --no-check-certificate
                          do not validate the certificate of HTTPS servers "))
   (format #t (G_ "
@@ -108,6 +113,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
                 (lambda (opt name arg result)
                   (define fmt-proc
                     (match arg
+                      ("base64"
+                       base64-encode)
                       ("nix-base32"
                        bytevector->nix-base32-string)
                       ("base32"
@@ -119,6 +126,13 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
 
                   (alist-cons 'format fmt-proc
                               (alist-delete 'format result))))
+        (option '(#\H "hash") #t #f
+                (lambda (opt name arg result)
+                  (match (lookup-hash-algorithm (string->symbol arg))
+                    (#f
+                     (leave (G_ "~a: unknown hash algorithm~%") arg))
+                    (algo
+                     (alist-cons 'hash-algorithm algo result)))))
         (option '("no-check-certificate") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'verify-certificate? #f result)))
@@ -175,7 +189,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
                       (or path
                           (leave (G_ "~a: download failed~%")
                                  arg))
-                    port-sha256))
+                    (cute port-hash (assoc-ref opts 'hash-algorithm) <>)))
            (fmt   (assq-ref opts 'format)))
       (format #t "~a~%~a~%" path (fmt hash))
       #t)))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index b8b2158195..9b4f419a24 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
@@ -20,12 +20,13 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix scripts hash)
-  #:use-module (guix base32)
   #:use-module (gcrypt hash)
   #:use-module (guix serialization)
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix base32)
+  #:autoload   (guix base64) (base64-encode)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -42,17 +43,21 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((format . ,bytevector->nix-base32-string)))
+  `((format . ,bytevector->nix-base32-string)
+    (hash-algorithm . ,(hash-algorithm sha256))))
 
 (define (show-help)
   (display (G_ "Usage: guix hash [OPTION] FILE
-Return the cryptographic hash of FILE.
-
-Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex'
-and 'hexadecimal' can be used as well).\n"))
+Return the cryptographic hash of FILE.\n"))
+  (newline)
+  (display (G_ "\
+Supported formats: 'base64', 'nix-base32' (default), 'base32',
+and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
   (format #t (G_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (G_ "
+  -H, --hash=ALGORITHM   use the given hash ALGORITHM"))
+  (format #t (G_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (G_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -69,10 +74,19 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\H "hash") #t #f
+                (lambda (opt name arg result)
+                  (match (lookup-hash-algorithm (string->symbol arg))
+                    (#f
+                     (leave (G_ "~a: unknown hash algorithm~%") arg))
+                    (algo
+                     (alist-cons 'hash-algorithm algo result)))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
                     (match arg
+                      ("base64"
+                       base64-encode)
                       ("nix-base32"
                        bytevector->nix-base32-string)
                       ("base32"
@@ -139,8 +153,11 @@ and 'hexadecimal' can be used as well).\n"))
               (force-output port)
               (get-hash))
             (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+              ("-" (port-hash (assoc-ref opts 'hash-algorithm)
+                              (current-input-port)))
+              (_   (call-with-input-file file
+                     (cute port-hash (assoc-ref opts 'hash-algorithm)
+                           <>)))))))
 
     (match args
       ((file)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index a69efa365e..1246147798 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -675,12 +675,13 @@ doesn't need it."
 (define (process-query opts)
   "Process any query specified by OPTS.  Return #t when a query was actually
 processed, #f otherwise."
-  (let* ((profiles (match (filter-map (match-lambda
-                                        (('profile . p) p)
-                                        (_              #f))
-                                      opts)
-                     (() (list %current-profile))
-                     (lst (reverse lst))))
+  (let* ((profiles (delete-duplicates
+                    (match (filter-map (match-lambda
+                                         (('profile . p) p)
+                                         (_              #f))
+                                       opts)
+                      (() (list %current-profile))
+                      (lst (reverse lst)))))
          (profile  (match profiles
                      ((head tail ...) head))))
     (match (assoc-ref opts 'query)
@@ -718,7 +719,8 @@ processed, #f otherwise."
 
       (('list-installed regexp)
        (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
-              (manifest  (profile-manifest profile))
+              (manifest  (concatenate-manifests
+                          (map profile-manifest profiles)))
               (installed (manifest-entries manifest)))
          (leave-on-EPIPE
           (for-each (match-lambda
@@ -729,8 +731,8 @@ processed, #f otherwise."
                                  name (or version "?") output path))))
 
                     ;; Show most recently installed packages last.
-                    (reverse installed)))
-         #t))
+                    (reverse installed))))
+       #t)
 
       (('list-available regexp)
        (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index dfe7ee7ad5..c386d81b8e 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -81,7 +81,8 @@
     (multiplexed-build-output? . #t)
     (graft? . #t)
     (debug . 0)
-    (verbosity . 1)))
+    (verbosity . 1)
+    (validate-pull . ,ensure-forward-channel-update)))
 
 (define (show-help)
   (display (G_ "Usage: guix pull [OPTION]...
@@ -95,6 +96,8 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
+      --allow-downgrades allow downgrades to earlier channel revisions"))
+  (display (G_ "
   -N, --news             display news compared to the previous generation"))
   (display (G_ "
   -l, --list-generations[=PATTERN]
@@ -158,6 +161,10 @@ Download and deploy the latest version of Guix.\n"))
          (option '("branch") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'ref `(branch . ,arg) result)))
+         (option '("allow-downgrades") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'validate-pull warn-about-backward-updates
+                               result)))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'profile (canonicalize-profile arg)
@@ -188,6 +195,21 @@ Download and deploy the latest version of Guix.\n"))
 
          %standard-build-options))
 
+(define (warn-about-backward-updates channel start instance relation)
+  "Warn about non-forward updates of CHANNEL from START to INSTANCE, without
+aborting."
+  (match relation
+    ((or 'ancestor 'self)
+     #t)
+    ('descendant
+     (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
+              (channel-name channel) start
+              (channel-instance-commit instance)))
+    ('unrelated
+     (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
+              (channel-name channel) start
+              (channel-instance-commit instance)))))
+
 (define* (display-profile-news profile #:key concise?
                                current-is-newer?)
   "Display what's up in PROFILE--new packages, and all that.  If
@@ -749,7 +771,9 @@ Use '~/.config/guix/channels.scm' instead."))
             (substitutes? (assoc-ref opts 'substitutes?))
             (dry-run?     (assoc-ref opts 'dry-run?))
             (channels     (channel-list opts))
-            (profile      (or (assoc-ref opts 'profile) %current-profile)))
+            (profile      (or (assoc-ref opts 'profile) %current-profile))
+            (current-channels (profile-channels profile))
+            (validate-pull    (assoc-ref opts 'validate-pull)))
        (cond ((assoc-ref opts 'query)
               (process-query opts profile))
              ((assoc-ref opts 'generation)
@@ -766,7 +790,12 @@ Use '~/.config/guix/channels.scm' instead."))
                       (ensure-default-profile)
                       (honor-x509-certificates store)
 
-                      (let ((instances (latest-channel-instances store channels)))
+                      (let ((instances
+                             (latest-channel-instances store channels
+                                                       #:current-channels
+                                                       current-channels
+                                                       #:validate-pull
+                                                       validate-pull)))
                         (format (current-error-port)
                                 (N_ "Building from this channel:~%"
                                     "Building from these channels:~%"