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 @@ | |||
| 50 | #:use-module (guix diagnostics) | 50 | #:use-module (guix diagnostics) |
| 51 | #:use-module (guix store) | 51 | #:use-module (guix store) |
| 52 | #:use-module (guix i18n) | 52 | #:use-module (guix i18n) |
| 53 | #:autoload (guix sets) (setq set-insert set-contains?) | ||
| 53 | #:use-module (srfi srfi-1) | 54 | #:use-module (srfi srfi-1) |
| 54 | #:use-module (srfi srfi-2) | 55 | #:use-module (srfi srfi-2) |
| 55 | #:use-module (srfi srfi-9) | 56 | #:use-module (srfi srfi-9) |
| @@ -91,6 +92,8 @@ | |||
| 91 | channel-instance-channel | 92 | channel-instance-channel |
| 92 | channel-instance-commit | 93 | channel-instance-commit |
| 93 | channel-instance-checkout | 94 | channel-instance-checkout |
| 95 | channel-instance-dependencies | ||
| 96 | (resolve-dependencies . channel-instance-dependency-resolver) | ||
| 94 | 97 | ||
| 95 | authenticate-channel | 98 | authenticate-channel |
| 96 | latest-channel-instances | 99 | latest-channel-instances |
| @@ -791,9 +794,24 @@ during this process." | |||
| 791 | #:built-in-builders | 794 | #:built-in-builders |
| 792 | built-in-builders)) | 795 | built-in-builders)) |
| 793 | 796 | ||
| 797 | (define (closure node edge) | ||
| 798 | "Return the closure of NODE following EDGE, a one-argument procedure, but | ||
| 799 | not NODE itself." | ||
| 800 | (let loop ((nodes (edge node)) | ||
| 801 | (visited (setq)) | ||
| 802 | (result '())) | ||
| 803 | (match nodes | ||
| 804 | (() result) | ||
| 805 | ((head . tail) | ||
| 806 | (if (set-contains? visited head) | ||
| 807 | (loop tail visited result) | ||
| 808 | (loop (append (edge head) tail) | ||
| 809 | (set-insert head visited) | ||
| 810 | (cons head result))))))) | ||
| 811 | |||
| 794 | (define (resolve-dependencies instances) | 812 | (define (resolve-dependencies instances) |
| 795 | "Return a procedure that, given one of the elements of INSTANCES, returns | 813 | "Return a procedure that, given one of the elements of INSTANCES, returns |
| 796 | list of instances it depends on." | 814 | list of instances it depends on, recursively." |
| 797 | (define channel-instance-name | 815 | (define channel-instance-name |
| 798 | (compose channel-name channel-instance-channel)) | 816 | (compose channel-name channel-instance-channel)) |
| 799 | 817 | ||
| @@ -817,7 +835,13 @@ list of instances it depends on." | |||
| 817 | instances)) | 835 | instances)) |
| 818 | 836 | ||
| 819 | (lambda (instance) | 837 | (lambda (instance) |
| 820 | (vhash-foldq* cons '() instance edges))) | 838 | ;; Return both direct and indirect dependencies of INSTANCE. That way, if |
| 839 | ;; INSTANCE uses a module of one of its direct dependencies, which in turn | ||
| 840 | ;; uses a module of an indirect dependency, INSTANCE will has access to | ||
| 841 | ;; the module of that indirect dependency. | ||
| 842 | (closure instance | ||
| 843 | (lambda (instance) | ||
| 844 | (vhash-foldq* cons '() instance edges))))) | ||
| 821 | 845 | ||
| 822 | (define* (channel-instance-derivations instances #:key system | 846 | (define* (channel-instance-derivations instances #:key system |
| 823 | built-in-builders) | 847 | 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 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> | 2 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
| 3 | ;;; Copyright © 2019-2020, 2022, 2024 Ludovic Courtès <ludo@gnu.org> | 3 | ;;; Copyright © 2019-2020, 2022, 2024, 2026 Ludovic Courtès <ludo@gnu.org> |
| 4 | ;;; | 4 | ;;; |
| 5 | ;;; This file is part of GNU Guix. | 5 | ;;; This file is part of GNU Guix. |
| 6 | ;;; | 6 | ;;; |
| @@ -278,6 +278,61 @@ | |||
| 278 | #:current-channels (list new) | 278 | #:current-channels (list new) |
| 279 | #:validate-pull validate-pull))))))) | 279 | #:validate-pull validate-pull))))))) |
| 280 | 280 | ||
| 281 | (test-equal "channel-instance-dependency-resolver" | ||
| 282 | '((c => (a b)) (b => (a)) (a => ())) | ||
| 283 | ;; Check that channel dependencies propagate. Here we create three channels | ||
| 284 | ;; that depend on one another: c depends on b, which depends on a. When | ||
| 285 | ;; resolving dependencies for c, we must get both a and b, such that | ||
| 286 | ;; (use-modules (b)) from channel c finds (a) when building the derivation | ||
| 287 | ;; of channel c. See <https://issues.guix.gnu.org/68797>. | ||
| 288 | (let ((call-with-channel | ||
| 289 | (lambda (name dependencies channels proc) | ||
| 290 | (with-temporary-git-repository directory | ||
| 291 | `((add ,(string-append (symbol->string name) ".scm") | ||
| 292 | ,(object->string | ||
| 293 | `(define-module (,name) | ||
| 294 | ,@(append-map (lambda (dependency) | ||
| 295 | `(#:use-module (,dependency))) | ||
| 296 | dependencies)))) | ||
| 297 | (add ".guix-channel" | ||
| 298 | ,(object->string | ||
| 299 | `(channel | ||
| 300 | (version 0) | ||
| 301 | (dependencies | ||
| 302 | ,@(map (lambda (dependency) | ||
| 303 | `(channel | ||
| 304 | (name ,dependency) | ||
| 305 | (url "http://example.org"))) | ||
| 306 | dependencies))))) | ||
| 307 | (commit "Initial commit.")) | ||
| 308 | (proc (cons (channel | ||
| 309 | (name name) | ||
| 310 | (url directory)) | ||
| 311 | channels)))))) | ||
| 312 | (define-syntax with-channels | ||
| 313 | (syntax-rules (&initialized) | ||
| 314 | ((_ &initialized binding (name dependencies) rest ... exp) | ||
| 315 | (call-with-channel 'name dependencies binding | ||
| 316 | (lambda (binding) | ||
| 317 | (with-channels &initialized binding | ||
| 318 | rest ... exp)))) | ||
| 319 | ((_ &initialized binding exp) exp) | ||
| 320 | ((_ binding rest ...) | ||
| 321 | (let ((binding '())) | ||
| 322 | (with-channels &initialized binding rest ...))))) | ||
| 323 | |||
| 324 | (with-channels | ||
| 325 | channels (a '()) (b '(a)) (c '(b)) | ||
| 326 | (with-store store | ||
| 327 | (let* ((instances (latest-channel-instances store channels)) | ||
| 328 | (resolve (channel-instance-dependency-resolver instances))) | ||
| 329 | (map (lambda (instance) | ||
| 330 | (list (channel-name (channel-instance-channel instance)) | ||
| 331 | '=> | ||
| 332 | (map (compose channel-name channel-instance-channel) | ||
| 333 | (resolve instance)))) | ||
| 334 | instances)))))) | ||
| 335 | |||
| 281 | (test-assert "channel-instances->manifest" | 336 | (test-assert "channel-instances->manifest" |
| 282 | ;; Compute the manifest for a graph of instances and make sure we get a | 337 | ;; Compute the manifest for a graph of instances and make sure we get a |
| 283 | ;; derivation graph that mirrors the instance graph. This test also ensures | 338 | ;; derivation graph that mirrors the instance graph. This test also ensures |
