06/11: channels: Make 'validate-pull' call right after clone/pull.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5bafc70d1e1daf6a91e8bf29a464263262505f2f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Jun 8 22:46:06 2020 +0200

    channels: Make 'validate-pull' call right after clone/pull.
    
    This should come before patching, authentication, etc.
    
    * guix/channels.scm (latest-channel-instance): Add #:validate-pull
    parameter and honor it.  Return a single value: the instance.
    (ensure-forward-channel-update): Change 'instance' parameter to 'commit'
    and adjust accordingly.
    (latest-channel-instances): Adjust to 'latest-channel-instance' changes.
    * guix/scripts/pull.scm (warn-about-backward-updates): Change 'instance'
    parameter to 'commit' and adjust accordingly.
    * tests/channels.scm ("latest-channel-instances #:validate-pull"):
    Likewise.
---
 guix/channels.scm     | 37 ++++++++++++++++++++-----------------
 guix/scripts/pull.scm | 10 ++++------
 tests/channels.scm    |  4 ++--
 3 files changed, 26 insertions(+), 25 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 1ce9150..02e361b 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -375,9 +375,12 @@ commits ~a to ~a (~h new commits)...~%")
 
 (define* (latest-channel-instance store channel
                                   #:key (patches %patches)
-                                  starting-commit)
-  "Return two values: the latest channel instance for CHANNEL, and its
-relation to STARTING-COMMIT when provided."
+                                  starting-commit
+                                  (validate-pull
+                                   ensure-forward-channel-update))
+  "Return the latest channel instance for CHANNEL.  When STARTING-COMMIT is
+true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
+their relation."
   (define (dot-git? file stat)
     (and (string=? (basename file) ".git")
          (eq? 'directory (stat:type stat))))
@@ -386,6 +389,9 @@ relation to STARTING-COMMIT when provided."
                 (update-cached-checkout (channel-url channel)
                                         #:ref (channel-reference channel)
                                         #:starting-commit starting-commit)))
+    (when relation
+      (validate-pull channel starting-commit commit relation))
+
     (if (channel-introduction channel)
         (authenticate-channel channel checkout commit)
         ;; TODO: Warn for all the channels once the authentication interface
@@ -403,12 +409,11 @@ cannot be authenticated~%")
     (let* ((name     (url+commit->name (channel-url channel) commit))
            (checkout (add-to-store store name #t "sha256" checkout
                                    #:select? (negate dot-git?))))
-      (values (channel-instance channel commit checkout)
-              relation))))
+      (channel-instance channel commit checkout))))
 
-(define (ensure-forward-channel-update channel start instance relation)
+(define (ensure-forward-channel-update channel start commit 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.
+ancestor of COMMIT, unless CHANNEL specifies a commit.
 
 This procedure implements a channel update policy meant to be used as a
 #:validate-pull argument."
@@ -422,8 +427,7 @@ This procedure implements a channel update policy meant to 
be used as a
                          (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))))
+                                 commit start))))
 
              ;; If the user asked for a specific commit, they might want
              ;; that to happen nevertheless, so tell them about the
@@ -482,14 +486,13 @@ depending on the policy it implements."
                              (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* ((current (current-commit (channel-name channel)))
+                            (instance
+                             (latest-channel-instance store channel
+                                                      #:validate-pull
+                                                      validate-pull
+                                                      #:starting-commit
+                                                      current)))
 
                        (let-values (((new-instances new-channels)
                                      (loop (channel-instance-dependencies 
instance)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index c386d81..d3d0d2b 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -195,20 +195,18 @@ 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
+(define (warn-about-backward-updates channel start commit relation)
+  "Warn about non-forward updates of CHANNEL from START to COMMIT, 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)))
+              (channel-name channel) start commit))
     ('unrelated
      (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
-              (channel-name channel) start
-              (channel-instance-commit instance)))))
+              (channel-name channel) start commit))))
 
 (define* (display-profile-news profile #:key concise?
                                current-is-newer?)
diff --git a/tests/channels.scm b/tests/channels.scm
index 2c85708..5f13a48 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -212,12 +212,12 @@
                                  (commit (oid->string (commit-id commit2)))))
                (old     (channel (inherit spec)
                                  (commit (oid->string (commit-id commit1))))))
-          (define (validate-pull channel current instance relation)
+          (define (validate-pull channel current commit relation)
             (return (and (eq? channel old)
                          (string=? (oid->string (commit-id commit2))
                                    current)
                          (string=? (oid->string (commit-id commit1))
-                                   (channel-instance-commit instance))
+                                   commit)
                          relation)))
 
           (with-store store