diff options
| -rw-r--r-- | guix/channels.scm | 28 | ||||
| -rw-r--r-- | tests/channels.scm | 57 |
2 files changed, 82 insertions, 3 deletions
diff --git a/guix/channels.scm b/guix/channels.scm index e7afa60c1ea..ebd09eba8d1 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -50,6 +50,7 @@ #:use-module (guix diagnostics) #:use-module (guix store) #:use-module (guix i18n) + #:autoload (guix sets) (setq set-insert set-contains?) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) @@ -91,6 +92,8 @@ channel-instance-channel channel-instance-commit channel-instance-checkout + channel-instance-dependencies + (resolve-dependencies . channel-instance-dependency-resolver) authenticate-channel latest-channel-instances @@ -791,9 +794,24 @@ during this process." #:built-in-builders built-in-builders)) +(define (closure node edge) + "Return the closure of NODE following EDGE, a one-argument procedure, but +not NODE itself." + (let loop ((nodes (edge node)) + (visited (setq)) + (result '())) + (match nodes + (() result) + ((head . tail) + (if (set-contains? visited head) + (loop tail visited result) + (loop (append (edge head) tail) + (set-insert head visited) + (cons head result))))))) + (define (resolve-dependencies instances) "Return a procedure that, given one of the elements of INSTANCES, returns -list of instances it depends on." +list of instances it depends on, recursively." (define channel-instance-name (compose channel-name channel-instance-channel)) @@ -817,7 +835,13 @@ list of instances it depends on." instances)) (lambda (instance) - (vhash-foldq* cons '() instance edges))) + ;; Return both direct and indirect dependencies of INSTANCE. That way, if + ;; INSTANCE uses a module of one of its direct dependencies, which in turn + ;; uses a module of an indirect dependency, INSTANCE will has access to + ;; the module of that indirect dependency. + (closure instance + (lambda (instance) + (vhash-foldq* cons '() instance edges))))) (define* (channel-instance-derivations instances #:key system built-in-builders) diff --git a/tests/channels.scm b/tests/channels.scm index 15deb551ffa..2df4c86b5a8 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, 2024 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019-2020, 2022, 2024, 2026 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -278,6 +278,61 @@ #:current-channels (list new) #:validate-pull validate-pull))))))) +(test-equal "channel-instance-dependency-resolver" + '((c => (a b)) (b => (a)) (a => ())) + ;; Check that channel dependencies propagate. Here we create three channels + ;; that depend on one another: c depends on b, which depends on a. When + ;; resolving dependencies for c, we must get both a and b, such that + ;; (use-modules (b)) from channel c finds (a) when building the derivation + ;; of channel c. See <https://issues.guix.gnu.org/68797>. + (let ((call-with-channel + (lambda (name dependencies channels proc) + (with-temporary-git-repository directory + `((add ,(string-append (symbol->string name) ".scm") + ,(object->string + `(define-module (,name) + ,@(append-map (lambda (dependency) + `(#:use-module (,dependency))) + dependencies)))) + (add ".guix-channel" + ,(object->string + `(channel + (version 0) + (dependencies + ,@(map (lambda (dependency) + `(channel + (name ,dependency) + (url "http://example.org"))) + dependencies))))) + (commit "Initial commit.")) + (proc (cons (channel + (name name) + (url directory)) + channels)))))) + (define-syntax with-channels + (syntax-rules (&initialized) + ((_ &initialized binding (name dependencies) rest ... exp) + (call-with-channel 'name dependencies binding + (lambda (binding) + (with-channels &initialized binding + rest ... exp)))) + ((_ &initialized binding exp) exp) + ((_ binding rest ...) + (let ((binding '())) + (with-channels &initialized binding rest ...))))) + + (with-channels + channels (a '()) (b '(a)) (c '(b)) + (with-store store + (let* ((instances (latest-channel-instances store channels)) + (resolve (channel-instance-dependency-resolver instances))) + (map (lambda (instance) + (list (channel-name (channel-instance-channel instance)) + '=> + (map (compose channel-name channel-instance-channel) + (resolve instance)))) + instances)))))) + (test-assert "channel-instances->manifest" ;; Compute the manifest for a graph of instances and make sure we get a ;; derivation graph that mirrors the instance graph. This test also ensures |