diff options
| -rw-r--r-- | guix/channels.scm | 132 | ||||
| -rw-r--r-- | tests/channels.scm | 51 |
2 files changed, 119 insertions, 64 deletions
diff --git a/guix/channels.scm b/guix/channels.scm index f01903642d..1b07eb5221 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -34,7 +34,6 @@ #:use-module (guix packages) #:use-module (guix progress) #:use-module (guix derivations) - #:use-module (guix combinators) #:use-module (guix diagnostics) #:use-module (guix sets) #:use-module (guix store) @@ -510,16 +509,6 @@ 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) - (member channel others - (lambda (a b) - (and (eq? (channel-name a) (channel-name b)) - (or (channel-commit b) - (not (or (channel-commit a) - (channel-commit b)))))))) - (define (current-commit name) ;; Return the current commit for channel NAME. (any (lambda (channel) @@ -527,60 +516,77 @@ depending on the policy it implements." (channel-commit channel))) current-channels)) + (define instance-name + (compose channel-name channel-instance-channel)) + + (define (same-named? channel) + (let ((name (channel-name channel))) + (lambda (candidate) + (eq? (channel-name candidate) name)))) + + (define (more-specific? a b) + ;; A is more specific than B if it specifies a commit. + (and (channel-commit a) + (not (channel-commit b)))) + (let loop ((channels channels) - (previous-channels '())) - ;; Accumulate a list of instances. A list of processed channels is also - ;; accumulated to decide on duplicate channel specifications. - (define-values (resulting-channels instances) - (fold2 (lambda (channel previous-channels instances) - (if (ignore? channel previous-channels) - (values previous-channels instances) - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let* ((current (current-commit (channel-name channel))) - (instance - (latest-channel-instance store channel - #:authenticate? - authenticate? - #:validate-pull - validate-pull - #:starting-commit - current))) - (when authenticate? - ;; CHANNEL is authenticated so we can trust the - ;; primary URL advertised in its metadata and warn - ;; about possibly stale mirrors. - (let ((primary-url (channel-instance-primary-url - instance))) - (unless (or (not primary-url) - (channel-commit channel) - (string=? primary-url (channel-url channel))) - (warning (G_ "pulled channel '~a' from a mirror \ + (previous-channels '()) + (instances '())) + (match channels + (() + (reverse instances)) + ((channel . rest) + (let ((previous (find (same-named? channel) previous-channels))) + ;; If there's already an instance for CHANNEL, keep the most specific + ;; one. + (if (and previous + (not (more-specific? channel previous))) + (loop rest previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let* ((current (current-commit (channel-name channel))) + (instance + (latest-channel-instance store channel + #:authenticate? + authenticate? + #:validate-pull + validate-pull + #:starting-commit + current))) + (when authenticate? + ;; CHANNEL is authenticated so we can trust the + ;; primary URL advertised in its metadata and warn + ;; about possibly stale mirrors. + (let ((primary-url (channel-instance-primary-url + instance))) + (unless (or (not primary-url) + (channel-commit channel) + (string=? primary-url (channel-url channel))) + (warning (G_ "pulled channel '~a' from a mirror \ of ~a, which might be stale~%") - (channel-name channel) - primary-url)))) - - (let-values (((new-instances new-channels) - (loop (channel-instance-dependencies instance) - previous-channels))) - (values (append (cons channel new-channels) - previous-channels) - (append (cons instance new-instances) - instances))))))) - previous-channels - '() ;instances - channels)) - - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - resulting-channels)))) + (channel-name channel) + primary-url)))) + + ;; Perform a breadth-first traversal with the idea that the + ;; user-provided channels may be more specific than what + ;; '.guix-channel' specifies, and so it is on those instances + ;; that 'channel-instance-dependencies' should be called. + (loop (append rest + (channel-instance-dependencies instance)) + (cons channel + (if previous + (delq previous previous-channels) + previous-channels)) + (cons instance + (if previous + (remove (lambda (instance) + (eq? (instance-name instance) + (channel-name channel))) + instances) + instances))))))))))) (define* (checkout->channel-instance checkout #:key commit diff --git a/tests/channels.scm b/tests/channels.scm index 27e8487fbc..c56e4e6a71 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019-2020, 2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -196,6 +196,55 @@ "abc1234"))) instances))))))) +(test-equal "latest-channel-instances reads dependencies from most-specific instance" + '(chan1 chan2) + ;; Here '.guix-channel' in DIRECTORY2 is less specific than the + ;; user-provided channel spec in ONE: the latter specifies a commit. Since + ;; the most specific one "wins", the bogus '.guix-channel' file added in + ;; DIRECTORY1 as its second commit must not be taken into account. + ;; See <https://issues.guix.gnu.org/68822>. + (with-temporary-git-repository directory1 + `((add "a.scm" "(define-module (a))") + (commit "first commit") + (add ".guix-channel" + ,(object->string + '(channel + (version 0) + (dependencies + ;; Attempting to fetch this dependency would fail. + (channel + (name nonexistent-dependency) + (url "http://guix.example.org/does-not-exist.git")))))) + (commit "second commit")) + (with-temporary-git-repository directory2 + `((add ".guix-channel" + ,(object->string + `(channel (version 0) + (dependencies + (channel + (name chan1) + ;; Note: no 'commit' field here. + (url ,(string-append "file://" directory1))))))) + (commit "initial commit")) + (with-repository directory1 repository + (let* ((commit (find-commit repository "first")) + (one (channel + (url (string-append "file://" directory1)) + (commit (oid->string (commit-id commit))) ;<- specific + (name 'chan1))) + (two (channel + (url (string-append "file://" directory2)) + (name 'chan2)))) + + (with-store store + (map (compose channel-name channel-instance-channel) + (delete-duplicates + (append (latest-channel-instances store (list one two)) + (latest-channel-instances store (list two one))) + (lambda (instance1 instance2) + (string=? (channel-instance-commit instance1) + (channel-instance-commit instance2))))))))))) + (test-equal "latest-channel-instances #:validate-pull" 'descendant |