From 9744cc7b4636fafb772c94adb8f05961b5b39f16 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 20 May 2020 23:18:09 +0200
Subject: 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'.
---
 guix/scripts/pull.scm | 35 ++++++++++++++++++++++++++++++++---
 1 file changed, 32 insertions(+), 3 deletions(-)

(limited to 'guix/scripts')

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 @@ (define %default-options
     (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]...
@@ -94,6 +95,8 @@ (define (show-help)
       --commit=COMMIT    download the specified COMMIT"))
   (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_ "
@@ -158,6 +161,10 @@ (define %options
          (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 @@ (define %options
 
          %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 @@ (define (guix-pull . args)
             (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 @@ (define (guix-pull . args)
                       (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:~%"
-- 
cgit v1.2.3