pull: Add fine-grained control for `guix pull --allow-downgrades`.issue-70353

Introduce the ability to specify channels for downgrades in `guix pull`,
enhancing security by enabling users to trust certain channels over
others. This update maintains backward compatibility and updates relevant
documentation.

* guix/scripts/pull.scm (allow-downgrades): Option accepts a list of
downgradable channels, add '-a' as its short version.
(%default-options): Remove validate-pull.
(channels-with-validations): New procedure.
* guix/channels.scm (latest-channel-instances): Signature change.
* doc/guix.texi (Invoking guix pull): Document changes.
* test/channels.scm (latest-channel-instances validate-pull): Adopt
latest-channel-instances signature change.
* guix/inferior.scm (cached-channel-instance): Adopt latest-channel-instances
signature change.
* guix/scripts/time-machine.scm (guix-time-machine): Adopt
latest-channel-instances signature change. (%reference-channels): compute JIT

Change-Id: If947a2453c520463d77da9591af9ac03e6472afc

6 files changed, 146 insertions, 73 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index fc28a15980..8c4dcee63e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4565,15 +4565,22 @@ Use @var{profile} instead of @file{~/.config/guix/current}.
 Show which channel commit(s) would be used and what would be built or
 substituted but do not actually do it.
 
-@item --allow-downgrades
-Allow pulling older or unrelated revisions of channels than those
-currently in use.
+@item --allow-downgrades[=channels]
+@itemx -a [channels]
+Allows pulling older or unrelated revisions of specified channels, or
+all channels if none are specified.
 
 @cindex downgrade attacks, protection against
-By default, @command{guix pull} protects against so-called ``downgrade
-attacks'' whereby the Git repository of a channel would be reset to an
-earlier or unrelated revision of itself, potentially leading you to
-install older, known-vulnerable versions of software packages.
+By default, @command{guix pull} safeguards against so-called ``downgrade
+attacks``, where a channel's Git repository is reset to a previous or
+unrelated revision, potentially causing the installation of older,
+vulnerable software versions. Without specifying channels, this
+protection is disabled entirely, posing a security risk.
+
+It's advisable to permit downgrades only for channels you trust
+implicitly, such as those you maintain. For all other channels,
+including the official Guix channel, downgrade protection remains
+recommended.
 
 @quotation Note
 Make sure you understand its security implications before using
diff --git a/guix/channels.scm b/guix/channels.scm
index 51024dcad4..58b1d7bdb1 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -497,26 +497,35 @@ information."
 
 (define* (latest-channel-instances store channels
                                    #:key
-                                   (current-channels '())
-                                   (authenticate? #t)
-                                   (validate-pull
-                                    ensure-forward-channel-update))
+                                   (channel-validation-pairs '())
+                                   (authenticate? #t))
   "Return a list of channel instances corresponding to the latest checkouts of
 CHANNELS and the channels on which they depend.
 
 When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
 \"channel introduction\".
 
-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."
+CHANNEL-VALIDATION-PAIRS is a list of pairs of currently used channels with their
+respective validation procedures: (current-channel . validate-pull).  The
+current-channel is compared against the newly-fetched instances of CHANNELS, and its
+validate-pull procedure is called for each channel update and can choose to emit
+warnings or raise an error, depending on the policy it implements."
   (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))
+    "Return the current commit for channel NAME."
+    (any (lambda (channel-with-validation)
+           (let ((channel (car channel-with-validation)))
+             (and (eq? (channel-name channel) name)
+                  (channel-commit channel))))
+         channel-validation-pairs))
+
+  (define (current-validate-pull name)
+    "Return the desired validate-pull procedure for channel NAME."
+    (any (lambda (channel-with-validation)
+           (let ((channel (car channel-with-validation))
+                 (validate-pull (cdr channel-with-validation)))
+             (and (eq? (channel-name channel) name)
+                  validate-pull)))
+         channel-validation-pairs))
 
   (define instance-name
     (compose channel-name channel-instance-channel))
@@ -544,20 +553,22 @@ depending on the policy it implements."
          (if (and previous
                   (not (more-specific? channel previous)))
              (loop rest previous-channels instances)
-             (begin
+             (let ((current (current-commit (channel-name channel)))
+                   (validate-pull (current-validate-pull (channel-name channel))))
+               ;; (format #t "channel '~a' is validated by '~a'~%"
+               ;;         (channel-name channel) (procedure-name validate-pull))
                (format (current-error-port)
                        (G_ "Updating channel '~a' from Git repository at '~a'...~%")
                        (channel-name channel)
                        (channel-url channel))
-               (let* ((current (current-commit (channel-name channel)))
-                      (instance
-                       (latest-channel-instance store channel
-                                                #:authenticate?
-                                                authenticate?
-                                                #:validate-pull
-                                                validate-pull
-                                                #:starting-commit
-                                                current)))
+               (let ((instance
+                      (latest-channel-instance store channel
+                                               #:authenticate?
+                                               authenticate?
+                                               #:validate-pull
+                                               validate-pull
+                                               #:starting-commit
+                                               current)))
                  (when authenticate?
                    ;; CHANNEL is authenticated so we can trust the
                    ;; primary URL advertised in its metadata and warn
@@ -1001,18 +1012,14 @@ channel instances."
 
 (define* (latest-channel-derivation #:optional (channels %default-channels)
                                     #:key
-                                    (current-channels '())
-                                    (validate-pull
-                                     ensure-forward-channel-update))
+                                    (channel-validation-pairs '()))
   "Return as a monadic value the derivation that builds the profile for the
 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-validation-pairs
+                                                  channel-validation-pairs)))
     (channel-instances->derivation instances)))
 
 (define* (sexp->channel sexp #:optional (name 'channel))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 190ba01b3c..3be9028afb 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -872,17 +872,16 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
                                   (authenticate? #t)
                                   (cache-directory (%inferior-cache-directory))
                                   (ttl (* 3600 24 30))
-                                  (reference-channels '())
-                                  (validate-channels (const #t)))
+                                  (channel-validation-pairs '()))
   "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
 The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
 reclaimed after TTL seconds.  This procedure opens a new connection to the
 build daemon.  AUTHENTICATE? determines whether CHANNELS are authenticated.
 
-VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
-instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to
-'latest-channel-instances' and should raise an exception in case a target
-channel commit is deemed \"invalid\"."
+CHANNEL-VALIDATION-PAIRS must be a list of pairs (channel . validation-pull) where
+validation-pull is a four-argument procedure used to validate corresponding channel
+instance. This procedure 'latest-channel-instances' and should raise an exception in
+case a target channel commit is deemed \"invalid\"."
   (define commits
     ;; Since computing the instances of CHANNELS is I/O-intensive, use a
     ;; cheaper way to get the commit list of CHANNELS.  This limits overhead
@@ -935,10 +934,8 @@ channel commit is deemed \"invalid\"."
                               -> (latest-channel-instances store channels
                                                            #:authenticate?
                                                            authenticate?
-                                                           #:current-channels
-                                                           reference-channels
-                                                           #:validate-pull
-                                                           validate-channels))
+                                                           #:channel-validation-pairs
+                                                           channel-validation-pairs))
                              (profile
                               (channel-instances->derivation instances)))
           (mbegin %store-monad
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58d3cd7e83..b79a4a0c95 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -76,8 +76,7 @@
     (graft? . #t)
     (debug . 0)
     (verbosity . 1)
-    (authenticate-channels? . #t)
-    (validate-pull . ,ensure-forward-channel-update)))
+    (authenticate-channels? . #t)))
 
 (define (show-help)
   (display (G_ "Usage: guix pull [OPTION]...
@@ -94,7 +93,8 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --branch=BRANCH    download the tip of the specified \"guix\" channel BRANCH"))
   (display (G_ "
-      --allow-downgrades allow downgrades to earlier channel revisions"))
+  -a, --allow-downgrades[=CHANNELS]
+                         allow downgrades to earlier revisions of CHANNELS"))
   (display (G_ "
       --disable-authentication
                          disable channel authentication"))
@@ -176,10 +176,37 @@ 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
+         (option '(#\a "allow-downgrades") #f #t
                  (lambda (opt name arg result)
-                   (alist-cons 'validate-pull warn-about-backward-updates
-                               result)))
+                   (cond
+                    ((string? arg)
+                     ((compose
+                       (cut alist-cons 'allow-downgrades <>
+                            (alist-delete 'allow-downgrades result))
+                       (cut append
+                            (or (assoc-ref result 'allow-downgrades)
+                                (list))
+                            <>))
+                      ;; Values may be also comma-separated. Possibilities:
+                      ;; -a val1 -a val2,val3 -a val4 -aval5
+                      (string-tokenize arg
+                                       (char-set-complement (char-set #\,)))))
+                    ((boolean? arg)
+                     ;; The command contains this option with no value
+                     ;; specified, (`arg' is #f). We'll interpreted this as
+                     ;; 'all channels can be downgraded'
+                     (alist-cons 'allow-downgrades #t result))
+                    (else
+                     ((compose
+                       (lambda (text)
+                         (raise (condition (&message (message text)))))
+                       (cut format #f <>
+                            "You found a bug:" arg name
+                            version system %guix-version
+                            %guix-bug-report-address))
+                      "~a The value '~a' of the '~a' option is unrecognized.
+(version: ~s; system: ~s; host version: ~s)
+Please report the COMPLETE output above by email to <~a>.~%")))))
          (option '("disable-authentication") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'authenticate-channels? #f result)))
@@ -828,6 +855,41 @@ Use '~/.config/guix/channels.scm' instead."))
 @command{sudo -i} or equivalent if you really want to pull as ~a.")
                        dir:user our:user)))))))))))
 
+(define (channels-with-validations downgradable-candidates channels)
+  "Return a list of pairs: channel + validate-pull procedure. The procedure
+is `warn-about-backward-updates' if a given channel is among the
+DOWNGRADABLE-CANDIDATES or `ensure-forward-channel-update' otherwise. E.g.:
+
+((channel1 . #<procedure warn-about-backward-updates ...>)
+ (channel2 . #<procedure ensure-forward-channel-update ...>))"
+  (cond
+   ((and (list? downgradable-candidates) (not (null? downgradable-candidates)))
+    (let ((downgradables-candidate-names (map string->symbol
+                                              downgradable-candidates))
+          (channels-names (map channel-name channels)))
+      (map (lambda (name)
+             (unless (member name channels-names)
+               (leave (G_ "'~a' must be one of '~a~'%") name channels-names)))
+           downgradables-candidate-names)
+      (let* ((downgradables-names
+              (filter (cut member <> downgradables-candidate-names)
+                      channels-names))
+             (downgradables
+              (filter (compose (cut member <> downgradables-names)
+                               (cut channel-name <>))
+                      channels))
+             (non-downgradables (lset-difference equal? channels
+                                                 downgradables)))
+        (append
+         (map (cut cons <> warn-about-backward-updates) downgradables)
+         (map (cut cons <> ensure-forward-channel-update) non-downgradables)))))
+
+   ((and (boolean? downgradable-candidates) downgradable-candidates)
+    (map (cut cons <> warn-about-backward-updates) channels))
+
+   (else
+    (map (cut cons <> ensure-forward-channel-update) channels))))
+
 
 (define-command (guix-pull . args)
   (synopsis "pull the latest revision of Guix")
@@ -844,7 +906,7 @@ Use '~/.config/guix/channels.scm' instead."))
             (dry-run?     (assoc-ref opts 'dry-run?))
             (profile      (or (assoc-ref opts 'profile) %current-profile))
             (current-channels (profile-channels profile))
-            (validate-pull    (assoc-ref opts 'validate-pull))
+            (allow-downgrades (assoc-ref opts 'allow-downgrades))
             (authenticate?    (assoc-ref opts 'authenticate-channels?)))
        (cond
         ((assoc-ref opts 'query)
@@ -868,14 +930,17 @@ Use '~/.config/guix/channels.scm' instead."))
                  (set-build-options-from-command-line store opts)
                  (ensure-default-profile)
                  (honor-x509-certificates store)
-
                  (let* ((channels (channel-list opts))
+                        (channel-validation-pairs
+                         ;; Only current-channels can be checked against
+                         ;; downgrade-attacks. New channels can't be
+                         ;; downgraded. Their commit history is unknown yet.
+                         (channels-with-validations allow-downgrades
+                                                    current-channels))
                         (instances
                          (latest-channel-instances store channels
-                                                   #:current-channels
-                                                   current-channels
-                                                   #:validate-pull
-                                                   validate-pull
+                                                   #:channel-validation-pairs
+                                                   channel-validation-pairs
                                                    #:authenticate?
                                                    authenticate?)))
                    (format (current-error-port)
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index d9ce85df84..139dff9e83 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -149,10 +149,6 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
 (define %oldest-possible-commit
   "4a0b87f0ec5b6c2dcf82b372dd20ca7ea6acdd9c") ;v0.16.0
 
-(define %reference-channels
-  (list (channel (inherit %default-guix-channel)
-                 (commit %oldest-possible-commit))))
-
 (define (validate-guix-channel channel start commit relation)
   "Raise an error if CHANNEL is the 'guix' channel and the RELATION of COMMIT
 to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor."
@@ -180,7 +176,12 @@ to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor."
             (substitutes?  (assoc-ref opts 'substitutes?))
             (authenticate? (assoc-ref opts 'authenticate-channels?)))
        (if command-line
-           (let* ((directory
+           (let* ((channel-validation-pairs
+                   (list (cons (channel (inherit %default-guix-channel)
+                                        (commit %oldest-possible-commit))
+                               validate-guix-channel)))
+
+                  (directory
                    (with-store store
                      (with-status-verbosity (assoc-ref opts 'verbosity)
                        (with-build-handler (build-notifier #:use-substitutes?
@@ -191,10 +192,8 @@ to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor."
                          (set-build-options-from-command-line store opts)
                          (cached-channel-instance store channels
                                                   #:authenticate? authenticate?
-                                                  #:reference-channels
-                                                  %reference-channels
-                                                  #:validate-channels
-                                                  validate-guix-channel)))))
+                                                  #:channel-validation-pairs
+                                                  channel-validation-pairs)))))
                   (executable (string-append directory "/bin/guix")))
              (apply execl (cons* executable executable command-line)))
            (warning (G_ "no command specified; nothing to do~%")))))))
diff --git a/tests/channels.scm b/tests/channels.scm
index c56e4e6a71..1bb85dd3e8 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -245,10 +245,8 @@
                     (string=? (channel-instance-commit instance1)
                               (channel-instance-commit instance2)))))))))))
 
-(test-equal "latest-channel-instances #:validate-pull"
+(test-equal "latest-channel-instances validate-pull"
   'descendant
-
-  ;; Make sure the #:validate-pull procedure receives the right values.
   (let/ec return
     (with-temporary-git-repository directory
         '((add "a.txt" "A")
@@ -275,8 +273,8 @@
           (with-store store
             ;; Attempt a downgrade from NEW to OLD.
             (latest-channel-instances store (list old)
-                                      #:current-channels (list new)
-                                      #:validate-pull validate-pull)))))))
+                                      #:channel-validation-pairs
+                                      (list (cons new validate-pull)))))))))
 
 (test-assert "channel-instances->manifest"
   ;; Compute the manifest for a graph of instances and make sure we get a