[bug#41425] [PATCH 4/5] channels: 'latest-channel-instances' guards against non-forward updates.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/channels.scm (latest-channel-instance): Add #:starting-commit and
pass it to 'update-cached-checkout'.  Return the commit relation as a
second value.
(ensure-forward-channel-update): New procedure.
(latest-channel-instances): Add #:current-channels and #:validate-pull.
[current-commit]: New procedure.
Pass #:starting-commit to 'latest-channel-instance'.  When the returned
relation is true, call VALIDATE-PULL.
(latest-channel-derivation): Add #:current-channels and #:validate-pull.
Pass them to 'latest-channel-instances*'.
* tests/channels.scm ("latest-channel-instances #:validate-pull"): New
test.
---
 guix/channels.scm  | 89 ++++++++++++++++++++++++++++++++++++++++------
 tests/channels.scm | 35 ++++++++++++++++++
 2 files changed, 114 insertions(+), 10 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 75b767a94c..70e2d7f07c 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 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,11 +233,51 @@ 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))))
+      (values (channel-instance channel commit checkout)
+              relation))))
 
-(define* (latest-channel-instances store channels)
+(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 (apply 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
+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."
+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)
@@ -244,6 +288,13 @@ CHANNELS and the channels on which they depend."
                        (not (or (channel-commit a)
                                 (channel-commit b))))))))
 
+  (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
@@ -257,7 +308,15 @@ CHANNELS and the channels on which they depend."
                              (G_ "Updating channel '~a' from Git repository at '~a'...~%")
                              (channel-name channel)
                              (channel-url channel))
-                     (let ((instance (latest-channel-instance store 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)))
@@ -617,10 +676,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/tests/channels.scm b/tests/channels.scm
index 3578b57204..3b141428c8 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -37,6 +37,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
+  #:use-module (ice-9 control)
   #:use-module (ice-9 match))
 
 (test-begin "channels")
@@ -178,6 +179,40 @@
                                           "abc1234")))
                          instances)))))))
 
+(unless (which (git-command)) (test-skip 1))
+(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")
+          (commit "first commit")
+          (add "b.scm" "#t")
+          (commit "second commit"))
+      (with-repository directory repository
+        (let* ((commit1 (find-commit repository "first"))
+               (commit2 (find-commit repository "second"))
+               (spec    (channel (url (string-append "file://" directory))
+                                 (name 'foo)))
+               (new     (channel (inherit spec)
+                                 (commit (oid->string (commit-id commit2)))))
+               (old     (channel (inherit spec)
+                                 (commit (oid->string (commit-id commit1))))))
+          (define (validate-pull channel current instance relation)
+            (return (and (eq? channel old)
+                         (string=? (oid->string (commit-id commit2))
+                                   current)
+                         (string=? (oid->string (commit-id commit1))
+                                   (channel-instance-commit instance))
+                         relation)))
+
+          (with-store store
+            ;; Attempt a downgrade from NEW to OLD.
+            (latest-channel-instances store (list old)
+                                      #:current-channels (list new)
+                                      #:validate-pull validate-pull)))))))
+
 (test-assert "channel-instances->manifest"
   ;; Compute the manifest for a graph of instances and make sure we get a
   ;; derivation graph that mirrors the instance graph.  This test also ensures
-- 
2.26.2