channels: ‘latest-channel-instances’ traverses user-provided channels first.
Previously, ‘latest-channel-instances’ would perform a depth-first traversal of channels. Since dependencies specified in ‘.guix-channel’ are usually less specific that those provided by the user, this would lead to the use of instances corresponding to those less specific specs, which in turn might declare dependencies that do not exist for the more specific instances. This commit changes ‘latest-channel-instances’ to perform a breadth-first traversal, thereby giving user-supplied channels higher precedence over dependencies found via ‘.guix-channel’. Fixes <https://issues.guix.gnu.org/68822>. * guix/channels.scm (latest-channel-instances)[ignore?]: Remove. [instance-name, same-named?, more-specific?]: New procedures. Rewrite as a breadth-first traversal using a regular loop. * tests/channels.scm ("latest-channel-instances reads dependencies from most-specific instance"): New test. Change-Id: Iba518145cfd209f04293a56246dbfee3b714650b
This commit is contained in:
Ludovic Courtès
Ludovic Courtès
parent
36d654fa54
commit
323b58ac18
|
|
@ -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))))
|
||||
(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))))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue