pull: Protect against downgrade attacks.

* guix/scripts/pull.scm (%default-options): Add 'validate-pull'.
(%options, show-help): Add '--allow-downgrades'.
(warn-about-backward-updates): New procedure.
(guix-pull): Pass #:current-channels and #:validate-pull to
'latest-channel-instances'.
* guix/channels.scm (ensure-forward-channel-update): Add hint for
when (channel-commit channel) is true.
* doc/guix.texi (Invoking guix pull): Document '--allow-downgrades'.

2 files changed, 52 insertions, 19 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index 70e2d7f07c..84c47fc0d0 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -246,25 +246,29 @@ This procedure implements a channel update policy meant to be used as a
     ('ancestor #t)
     ('self #t)
     (_
-     (raise (apply make-compound-condition
-                   (condition
-                    (&message (message
-                               (format #f (G_ "\
+     (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))))
-
-                   ;; Don't show the hint when the user explicitly specified a
-                   ;; commit in CHANNEL.
-                   (if (channel-commit channel)
-                       '()
-                       (list (condition
-                              (&fix-hint
-                               (hint (G_ "This could indicate that the channel has
+                                 (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.")))))))))))
+allow non-forward updates."))))))))))
 
 (define* (latest-channel-instances store channels
                                    #:key
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:~%"