Merge branch 'master' into staging

12 files changed, 389 insertions, 112 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index f0174de767..84c47fc0d0 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -73,6 +73,7 @@
             channel-instances->manifest
             %channel-profile-hooks
             channel-instances->derivation
+            ensure-forward-channel-update
 
             profile-channels
 
@@ -212,15 +213,18 @@ result is unspecified."
        (loop rest)))))
 
 (define* (latest-channel-instance store channel
-                                  #:key (patches %patches))
-  "Return the latest channel instance for CHANNEL."
+                                  #:key (patches %patches)
+                                  starting-commit)
+  "Return two values: the latest channel instance for CHANNEL, and its
+relation to STARTING-COMMIT when provided."
   (define (dot-git? file stat)
     (and (string=? (basename file) ".git")
          (eq? 'directory (stat:type stat))))
 
-  (let-values (((checkout commit)
+  (let-values (((checkout commit relation)
                 (update-cached-checkout (channel-url channel)
-                                        #:ref (channel-reference channel))))
+                                        #:ref (channel-reference channel)
+                                        #:starting-commit starting-commit)))
     (when (guix-channel? channel)
       ;; Apply the relevant subset of PATCHES directly in CHECKOUT.  This is
       ;; safe to do because 'switch-to-ref' eventually does a hard reset.
@@ -229,12 +233,55 @@ result is unspecified."
     (let* ((name     (url+commit->name (channel-url channel) commit))
            (checkout (add-to-store store name #t "sha256" checkout
                                    #:select? (negate dot-git?))))
-      (channel-instance channel commit checkout))))
-
-(define* (latest-channel-instances store channels #:optional (previous-channels '()))
+      (values (channel-instance channel commit checkout)
+              relation))))
+
+(define (ensure-forward-channel-update channel start instance relation)
+  "Raise an error if RELATION is not 'ancestor, meaning that START is not an
+ancestor of the commit in INSTANCE, unless CHANNEL specifies a commit.
+
+This procedure implements a channel update policy meant to be used as a
+#:validate-pull argument."
+  (match relation
+    ('ancestor #t)
+    ('self #t)
+    (_
+     (raise (make-compound-condition
+             (condition
+              (&message (message
+                         (format #f (G_ "\
+aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
+                                 (channel-name channel)
+                                 (channel-instance-commit instance)
+                                 start))))
+
+             ;; If the user asked for a specific commit, they might want
+             ;; that to happen nevertheless, so tell them about the
+             ;; relevant 'guix pull' option.
+             (if (channel-commit channel)
+                 (condition
+                  (&fix-hint
+                   (hint (G_ "Use @option{--allow-downgrades} to force
+this downgrade."))))
+                 (condition
+                  (&fix-hint
+                   (hint (G_ "This could indicate that the channel has
+been tampered with and is trying to force a roll-back, preventing you from
+getting the latest updates.  If you think this is not the case, explicitly
+allow non-forward updates."))))))))))
+
+(define* (latest-channel-instances store channels
+                                   #:key
+                                   (current-channels '())
+                                   (validate-pull
+                                    ensure-forward-channel-update))
   "Return a list of channel instances corresponding to the latest checkouts of
-CHANNELS and the channels on which they depend.  PREVIOUS-CHANNELS is a list
-of previously processed channels."
+CHANNELS and the channels on which they depend.
+
+CURRENT-CHANNELS is the list of currently used channels.  It is compared
+against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
+for each channel update and can choose to emit warnings or raise an error,
+depending on the policy it implements."
   ;; Only process channels that are unique, or that are more specific than a
   ;; previous channel specification.
   (define (ignore? channel others)
@@ -245,38 +292,53 @@ of previously processed channels."
                        (not (or (channel-commit a)
                                 (channel-commit b))))))))
 
-  ;; Accumulate a list of instances.  A list of processed channels is also
-  ;; accumulated to decide on duplicate channel specifications.
-  (define-values (resulting-channels instances)
-    (fold2 (lambda (channel previous-channels instances)
-             (if (ignore? channel previous-channels)
-                 (values previous-channels instances)
-                 (begin
-                   (format (current-error-port)
-                           (G_ "Updating channel '~a' from Git repository at '~a'...~%")
-                           (channel-name channel)
-                           (channel-url channel))
-                   (let ((instance (latest-channel-instance store channel)))
-                     (let-values (((new-instances new-channels)
-                                   (latest-channel-instances
-                                    store
-                                    (channel-instance-dependencies instance)
-                                    previous-channels)))
-                       (values (append (cons channel new-channels)
-                                       previous-channels)
-                               (append (cons instance new-instances)
-                                       instances)))))))
-           previous-channels
-           '()                                    ;instances
-           channels))
-
-  (let ((instance-name (compose channel-name channel-instance-channel)))
-    ;; Remove all earlier channel specifications if they are followed by a
-    ;; more specific one.
-    (values (delete-duplicates instances
-                               (lambda (a b)
-                                 (eq? (instance-name a) (instance-name b))))
-            resulting-channels)))
+  (define (current-commit name)
+    ;; Return the current commit for channel NAME.
+    (any (lambda (channel)
+           (and (eq? (channel-name channel) name)
+                (channel-commit channel)))
+         current-channels))
+
+  (let loop ((channels channels)
+             (previous-channels '()))
+    ;; Accumulate a list of instances.  A list of processed channels is also
+    ;; accumulated to decide on duplicate channel specifications.
+    (define-values (resulting-channels instances)
+      (fold2 (lambda (channel previous-channels instances)
+               (if (ignore? channel previous-channels)
+                   (values previous-channels instances)
+                   (begin
+                     (format (current-error-port)
+                             (G_ "Updating channel '~a' from Git repository at '~a'...~%")
+                             (channel-name channel)
+                             (channel-url channel))
+                     (let*-values (((current)
+                                    (current-commit (channel-name channel)))
+                                   ((instance relation)
+                                    (latest-channel-instance store channel
+                                                             #:starting-commit
+                                                             current)))
+                       (when relation
+                         (validate-pull channel current instance relation))
+
+                       (let-values (((new-instances new-channels)
+                                     (loop (channel-instance-dependencies instance)
+                                           previous-channels)))
+                         (values (append (cons channel new-channels)
+                                         previous-channels)
+                                 (append (cons instance new-instances)
+                                         instances)))))))
+             previous-channels
+             '()                                  ;instances
+             channels))
+
+    (let ((instance-name (compose channel-name channel-instance-channel)))
+      ;; Remove all earlier channel specifications if they are followed by a
+      ;; more specific one.
+      (values (delete-duplicates instances
+                                 (lambda (a b)
+                                   (eq? (instance-name a) (instance-name b))))
+              resulting-channels))))
 
 (define* (checkout->channel-instance checkout
                                      #:key commit
@@ -618,10 +680,20 @@ channel instances."
 (define latest-channel-instances*
   (store-lift latest-channel-instances))
 
-(define* (latest-channel-derivation #:optional (channels %default-channels))
+(define* (latest-channel-derivation #:optional (channels %default-channels)
+                                    #:key
+                                    (current-channels '())
+                                    (validate-pull
+                                     ensure-forward-channel-update))
   "Return as a monadic value the derivation that builds the profile for the
-latest instances of CHANNELS."
-  (mlet %store-monad ((instances (latest-channel-instances* channels)))
+latest instances of CHANNELS.  CURRENT-CHANNELS and VALIDATE-PULL are passed
+to 'latest-channel-instances'."
+  (mlet %store-monad ((instances
+                       (latest-channel-instances* channels
+                                                  #:current-channels
+                                                  current-channels
+                                                  #:validate-pull
+                                                  validate-pull)))
     (channel-instances->derivation instances)))
 
 (define (profile-channels profile)
diff --git a/guix/git.scm b/guix/git.scm
index 92121156cf..ab3b5075b1 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -43,6 +43,7 @@
             url+commit->name
             latest-repository-commit
             commit-difference
+            commit-relation
 
             git-checkout
             git-checkout?
@@ -261,14 +262,16 @@ definitely available in REPOSITORY, false otherwise."
                                  #:key
                                  (ref '(branch . "master"))
                                  recursive?
+                                 starting-commit
                                  (log-port (%make-void-port "w"))
                                  (cache-directory
                                   (url-cache-directory
                                    url (%repository-cache-directory)
                                    #:recursive? recursive?)))
-  "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
+  "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return three
 values: the cache directory name, and the SHA1 commit (a string) corresponding
-to REF.
+to REF, and the relation of the new commit relative to STARTING-COMMIT (if
+provided) as returned by 'commit-relation'.
 
 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
@@ -301,7 +304,17 @@ When RECURSIVE? is true, check out submodules as well, if any."
            (remote-fetch (remote-lookup repository "origin"))))
      (when recursive?
        (update-submodules repository #:log-port log-port))
-     (let ((oid (switch-to-ref repository canonical-ref)))
+
+     ;; Note: call 'commit-relation' from here because it's more efficient
+     ;; than letting users re-open the checkout later on.
+     (let* ((oid      (switch-to-ref repository canonical-ref))
+            (new      (and starting-commit
+                           (commit-lookup repository oid)))
+            (old      (and starting-commit
+                           (commit-lookup repository
+                                          (string->oid starting-commit))))
+            (relation (and starting-commit
+                           (commit-relation old new))))
 
        ;; Reclaim file descriptors and memory mappings associated with
        ;; REPOSITORY as soon as possible.
@@ -309,7 +322,7 @@ When RECURSIVE? is true, check out submodules as well, if any."
                               'repository-close!)
          (repository-close! repository))
 
-       (values cache-directory (oid->string oid))))))
+       (values cache-directory (oid->string oid) relation)))))
 
 (define* (latest-repository-commit store url
                                    #:key
@@ -342,7 +355,7 @@ Log progress and checkout info to LOG-PORT."
 
   (format log-port "updating checkout of '~a'...~%" url)
   (let*-values
-      (((checkout commit)
+      (((checkout commit _)
         (update-cached-checkout url
                                 #:recursive? recursive?
                                 #:ref ref
@@ -405,6 +418,21 @@ that of OLD."
                  (cons head result)
                  (set-insert head visited)))))))
 
+(define (commit-relation old new)
+  "Return a symbol denoting the relation between OLD and NEW, two commit
+objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
+'unrelated, or 'self (OLD and NEW are the same commit)."
+  (if (eq? old new)
+      'self
+      (let ((newest (commit-closure new)))
+        (if (set-contains? newest old)
+            'ancestor
+            (let* ((seen   (list->setq (commit-parents new)))
+                   (oldest (commit-closure old seen)))
+              (if (set-contains? oldest new)
+                  'descendant
+                  'unrelated))))))
+
 
 ;;;
 ;;; Checkouts.
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index ae7df8a8b5..9cda3da006 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -115,7 +115,7 @@
 (define (get-opam-repository)
   "Update or fetch the latest version of the opam repository and return the
 path to the repository."
-  (receive (location commit)
+  (receive (location commit _)
     (update-cached-checkout "https://github.com/ocaml/opam-repository")
     location))
 
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 3809c3d074..0cfa1f8321 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -24,7 +24,7 @@
 (define-module (guix import utils)
   #:use-module (guix base32)
   #:use-module ((guix build download) #:prefix build:)
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix http-client)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix utils)
diff --git a/guix/lint.scm b/guix/lint.scm
index e192f292a4..6271894360 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1154,15 +1154,18 @@ try again later")
           ((? origin? origin)
            ;; Since "save" origins are not supported for non-VCS source, all
            ;; we can do is tell whether a given tarball is available or not.
-           (if (origin-sha256 origin)             ;XXX: for ungoogled-chromium
-               (match (lookup-content (origin-sha256 origin) "sha256")
-                 (#f
-                  (list (make-warning package
-                                      (G_ "source not archived on Software \
+           (if (origin-hash origin)               ;XXX: for ungoogled-chromium
+               (let ((hash (origin-hash origin)))
+                 (match (lookup-content (content-hash-value hash)
+                                        (symbol->string
+                                         (content-hash-algorithm hash)))
+                   (#f
+                    (list (make-warning package
+                                        (G_ "source not archived on Software \
 Heritage")
-                                      #:field 'source)))
-                 ((? content?)
-                  '()))
+                                        #:field 'source)))
+                   ((? content?)
+                    '())))
                '()))))
       (match-lambda*
         ((key url method response)
diff --git a/guix/packages.scm b/guix/packages.scm
index 3fff50a6e8..3d9988d836 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -28,12 +28,15 @@
   #:use-module (guix monads)
   #:use-module (guix gexp)
   #:use-module (guix base32)
+  #:autoload   (guix base64) (base64-decode)
   #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix memoization)
   #:use-module (guix build-system)
   #:use-module (guix search-paths)
   #:use-module (guix sets)
+  #:use-module (guix deprecation)
+  #:use-module (guix i18n)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)
@@ -43,16 +46,23 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:use-module (web uri)
   #:re-export (%current-system
                %current-target-system
                search-path-specification)         ;for convenience
-  #:export (origin
+  #:export (content-hash
+            content-hash?
+            content-hash-algorithm
+            content-hash-value
+
+            origin
             origin?
             this-origin
             origin-uri
             origin-method
-            origin-sha256
+            origin-hash
+            origin-sha256                         ;deprecated
             origin-file-name
             origin-actual-file-name
             origin-patches
@@ -62,6 +72,7 @@
             origin-snippet
             origin-modules
             base32
+            base64
 
             package
             package?
@@ -155,15 +166,79 @@
 ;;;
 ;;; Code:
 
+;; Crytographic content hash.
+(define-immutable-record-type <content-hash>
+  (%content-hash algorithm value)
+  content-hash?
+  (algorithm content-hash-algorithm)              ;symbol
+  (value     content-hash-value))                 ;bytevector
+
+(define-syntax-rule (define-content-hash-constructor name
+                      (algorithm size) ...)
+  "Define NAME as a <content-hash> constructor that ensures that (1) its
+second argument is among the listed ALGORITHM, and (2), when possible, that
+its first argument has the right size for the chosen algorithm."
+  (define-syntax name
+    (lambda (s)
+      (syntax-case s (algorithm ...)
+        ((_ bv algorithm)
+         (let ((bv* (syntax->datum #'bv)))
+           (when (and (bytevector? bv*)
+                      (not (= size (bytevector-length bv*))))
+             (syntax-violation 'content-hash "invalid content hash length" s))
+           #'(%content-hash 'algorithm bv)))
+        ...))))
+
+(define-content-hash-constructor build-content-hash
+  (sha256 32)
+  (sha512 64))
+
+(define-syntax content-hash
+  (lambda (s)
+    "Return a content hash with the given parameters.  The default hash
+algorithm is sha256.  If the first argument is a literal string, it is decoded
+as base32.  Otherwise, it must be a bytevector."
+    ;; What we'd really want here is something like C++ 'constexpr'.
+    (syntax-case s ()
+      ((_ str)
+       (string? (syntax->datum #'str))
+       #'(content-hash str sha256))
+      ((_ str algorithm)
+       (string? (syntax->datum #'str))
+       (with-syntax ((bv (base32 (syntax->datum #'str))))
+         #'(content-hash bv algorithm)))
+      ((_ (id str) algorithm)
+       (and (string? (syntax->datum #'str))
+            (free-identifier=? #'id #'base32))
+       (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str))))
+         #'(content-hash bv algorithm)))
+      ((_ (id str) algorithm)
+       (and (string? (syntax->datum #'str))
+            (free-identifier=? #'id #'base64))
+       (with-syntax ((bv (base64-decode (syntax->datum #'str))))
+         #'(content-hash bv algorithm)))
+      ((_ bv)
+       #'(content-hash bv sha256))
+      ((_ bv hash)
+       #'(build-content-hash bv hash)))))
+
+(define (print-content-hash hash port)
+  (format port "#<content-hash ~a:~a>"
+          (content-hash-algorithm hash)
+          (bytevector->nix-base32-string (content-hash-value hash))))
+
+(set-record-type-printer! <content-hash> print-content-hash)
+
+
 ;; The source of a package, such as a tarball URL and fetcher---called
 ;; "origin" to avoid name clash with `package-source', `source', etc.
 (define-record-type* <origin>
-  origin make-origin
+  %origin make-origin
   origin?
   this-origin
   (uri       origin-uri)                          ; string
   (method    origin-method)                       ; procedure
-  (sha256    origin-sha256)                       ; bytevector
+  (hash      origin-hash)                         ; <content-hash>
   (file-name origin-file-name (default #f))       ; optional file name
 
   ;; Patches are delayed so that the 'search-patch' calls are made lazily,
@@ -186,30 +261,60 @@
   (patch-guile origin-patch-guile                 ; package or #f
                (default #f)))
 
+(define-syntax origin-compatibility-helper
+  (syntax-rules (sha256)
+    ((_ () (fields ...))
+     (%origin fields ...))
+    ((_ ((sha256 exp) rest ...) (others ...))
+     (%origin others ...
+              (hash (content-hash exp sha256))
+              rest ...))
+    ((_ (field rest ...) (others ...))
+     (origin-compatibility-helper (rest ...)
+                                  (others ... field)))))
+
+(define-syntax-rule (origin fields ...)
+  "Build an <origin> record, automatically converting 'sha256' field
+specifications to 'hash'."
+  (origin-compatibility-helper (fields ...) ()))
+
+(define-deprecated (origin-sha256 origin)
+  origin-hash
+  (let ((hash (origin-hash origin)))
+    (unless (eq? (content-hash-algorithm hash) 'sha256)
+      (raise (condition (&message
+                         (message (G_ "no SHA256 hash for origin"))))))
+    (content-hash-value hash)))
+
 (define (print-origin origin port)
   "Write a concise representation of ORIGIN to PORT."
   (match origin
-    (($ <origin> uri method sha256 file-name patches)
+    (($ <origin> uri method hash file-name patches)
      (simple-format port "#<origin ~s ~a ~s ~a>"
-                    uri (bytevector->base32-string sha256)
+                    uri hash
                     (force patches)
                     (number->string (object-address origin) 16)))))
 
 (set-record-type-printer! <origin> print-origin)
 
-(define-syntax base32
-  (lambda (s)
-    "Return the bytevector corresponding to the given Nix-base32
+(define-syntax-rule (define-compile-time-decoder name string->bytevector)
+  "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
+if possible."
+  (define-syntax name
+    (lambda (s)
+      "Return the bytevector corresponding to the given textual
 representation."
-    (syntax-case s ()
-      ((_ str)
-       (string? (syntax->datum #'str))
-       ;; A literal string: do the conversion at expansion time.
-       (with-syntax ((bv (nix-base32-string->bytevector
-                          (syntax->datum #'str))))
-         #''bv))
-      ((_ str)
-       #'(nix-base32-string->bytevector str)))))
+      (syntax-case s ()
+        ((_ str)
+         (string? (syntax->datum #'str))
+         ;; A literal string: do the conversion at expansion time.
+         (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
+           #''bv))
+        ((_ str)
+         #'(string->bytevector str))))))
+
+(define-compile-time-decoder base32 nix-base32-string->bytevector)
+(define-compile-time-decoder base64 base64-decode)
 
 (define (origin-actual-file-name origin)
   "Return the file name of ORIGIN, either its 'file-name' field or the file
@@ -231,6 +336,7 @@ name of its URI."
          ;; git, svn, cvs, etc. reference
          #f))))
 
+
 (define %supported-systems
   ;; This is the list of system types that are supported.  By default, we
   ;; expect all packages to build successfully here.
@@ -1381,14 +1487,19 @@ unless you know what you are doing."
                              #:optional (system (%current-system)))
   "Return the derivation corresponding to ORIGIN."
   (match origin
-    (($ <origin> uri method sha256 name (= force ()) #f)
+    (($ <origin> uri method hash name (= force ()) #f)
      ;; No patches, no snippet: this is a fixed-output derivation.
-     (method uri 'sha256 sha256 name #:system system))
-    (($ <origin> uri method sha256 name (= force (patches ...)) snippet
+     (method uri
+             (content-hash-algorithm hash)
+             (content-hash-value hash)
+             name #:system system))
+    (($ <origin> uri method hash name (= force (patches ...)) snippet
         (flags ...) inputs (modules ...) guile-for-build)
      ;; Patches and/or a snippet.
-     (mlet %store-monad ((source (method uri 'sha256 sha256 name
-                                         #:system system))
+     (mlet %store-monad ((source (method uri
+                                         (content-hash-algorithm hash)
+                                         (content-hash-value hash)
+                                         name #:system system))
                          (guile  (package->derivation (or guile-for-build
                                                           (default-guile))
                                                       system
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:~%"
diff --git a/guix/tests.scm b/guix/tests.scm
index 95a7d7c4b8..3ccf049a7d 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -26,7 +26,7 @@
   #:use-module (guix monads)
   #:use-module ((guix utils) #:select (substitute-keyword-arguments))
   #:use-module ((guix build utils) #:select (mkdir-p))
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
diff --git a/guix/upstream.scm b/guix/upstream.scm
index c11de0b25b..67d0eeefbb 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
@@ -441,7 +441,8 @@ new version string if an update was made, and #f otherwise."
     (if version-loc
         (let* ((loc         (package-location package))
                (old-version (package-version package))
-               (old-hash    (origin-sha256 (package-source package)))
+               (old-hash    (content-hash-value
+                             (origin-hash (package-source package))))
                (old-url     (match (origin-uri (package-source package))
                               ((? string? url) url)
                               (_ #f)))