From 5bafc70d1e1daf6a91e8bf29a464263262505f2f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jun 2020 22:46:06 +0200 Subject: 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 1ce915002c..02e361bd77 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 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 -- cgit v1.2.3