unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludo@gnu.org>
To: 41767@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#41767] [PATCH 5/9] channels: Make 'validate-pull' call right after clone/pull.
Date: Tue,  9 Jun 2020 00:02:52 +0200	[thread overview]
Message-ID: <20200608220256.3267-5-ludo@gnu.org> (raw)
In-Reply-To: <20200608220256.3267-1-ludo@gnu.org>

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 c2ea0e26ff..6047b51010 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -376,9 +376,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))))
@@ -387,6 +390,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 @@ relation to STARTING-COMMIT when provided."
     (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 c386d81b8e..d3d0d2bd64 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 2c857083e9..5f13a48ec1 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
-- 
2.26.2





  parent reply	other threads:[~2020-06-08 22:04 UTC|newest]

Thread overview: 21+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-06-08 21:52 [bug#41767] [PATCH 0/9] Authenticate channels Ludovic Courtès
2020-06-08 22:02 ` [bug#41767] [PATCH 1/9] git-authenticate: Cache takes a key parameter Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 2/9] git-authenticate: 'authenticate-commits' takes a #:keyring parameter Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 3/9] tests: Move OpenPGP helpers to (guix tests gnupg) Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 4/9] channels: 'latest-channel-instance' authenticates Git checkouts Ludovic Courtès
2020-06-09 17:49     ` Maxim Cournoyer
2020-06-11  9:24       ` Ludovic Courtès
2020-06-11 13:15         ` Maxim Cournoyer
2020-06-08 22:02   ` Ludovic Courtès [this message]
2020-06-08 22:02   ` [bug#41767] [PATCH 6/9] .guix-channel: Add 'keyring-reference' Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 7/9] channels: Automatically add introduction for the official 'guix' channel Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 8/9] pull: Add '--disable-authentication' Ludovic Courtès
2020-06-08 22:02   ` [bug#41767] [PATCH 9/9] DROP? channels: Add prehistorical authorizations to <channel-introduction> Ludovic Courtès
2020-06-09 18:35     ` Maxim Cournoyer
2020-06-10 13:21       ` Ludovic Courtès
2020-06-09  7:15 ` [bug#41767] [PATCH 0/9] Authenticate channels Ludovic Courtès
2020-06-09 10:52 ` zimoun
2020-06-09 14:16   ` Ludovic Courtès
2020-06-13 11:42     ` zimoun
2020-06-14 13:51       ` Ludovic Courtès
2020-06-16 14:22 ` bug#41767: " Ludovic Courtès

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20200608220256.3267-5-ludo@gnu.org \
    --to=ludo@gnu.org \
    --cc=41767@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).