mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2026-05-24 18:11:51 +02:00
channels: Don't pull from the same channel more than once.
Previous 'channel-instance->manifest' would call
'latest-channel-derivation', which could trigger another round of
'latest-repository-commit' for no good reason.
* guix/channels.scm (resolve-dependencies): New procedure.
(channel-instance-derivations)[edges]: New variable.
[instance->derivation]: New procedure.
* tests/channels.scm (make-instance): Use 'checkout->channel-instance'
instead of 'channel-instance'.
("channel-instances->manifest"): New test.
This commit is contained in:
+82
-2
@@ -18,9 +18,15 @@
|
||||
|
||||
(define-module (test-channels)
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module ((guix build syscalls) #:select (mkdtemp!))
|
||||
#:use-module (guix tests)
|
||||
#:use-module (guix store)
|
||||
#:use-module ((guix grafts) #:select (%graft?))
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
@@ -34,8 +40,9 @@
|
||||
(and spec
|
||||
(with-output-to-file (string-append instance-dir "/.guix-channel")
|
||||
(lambda _ (format #t "~a" spec))))
|
||||
((@@ (guix channels) channel-instance)
|
||||
name commit instance-dir))
|
||||
(checkout->channel-instance instance-dir
|
||||
#:commit commit
|
||||
#:name name))
|
||||
|
||||
(define instance--boring (make-instance))
|
||||
(define instance--no-deps
|
||||
@@ -136,4 +143,77 @@
|
||||
'abc1234)))
|
||||
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
|
||||
;; we don't try to access Git repositores at all at this stage.
|
||||
(let* ((spec (lambda deps
|
||||
`(channel (version 0)
|
||||
(dependencies
|
||||
,@(map (lambda (dep)
|
||||
`(channel
|
||||
(name ,dep)
|
||||
(url "http://example.org")))
|
||||
deps)))))
|
||||
(guix (make-instance #:name 'guix))
|
||||
(instance0 (make-instance #:name 'a))
|
||||
(instance1 (make-instance #:name 'b #:spec (spec 'a)))
|
||||
(instance2 (make-instance #:name 'c #:spec (spec 'b)))
|
||||
(instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
|
||||
(%graft? #f) ;don't try to build stuff
|
||||
|
||||
;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
|
||||
(let ((source (channel-instance-checkout guix)))
|
||||
(mkdir (string-append source "/build-aux"))
|
||||
(call-with-output-file (string-append source
|
||||
"/build-aux/build-self.scm")
|
||||
(lambda (port)
|
||||
(write '(begin
|
||||
(use-modules (guix) (gnu packages bootstrap))
|
||||
|
||||
(lambda _
|
||||
(package->derivation %bootstrap-guile)))
|
||||
port))))
|
||||
|
||||
(with-store store
|
||||
(let ()
|
||||
(define manifest
|
||||
(run-with-store store
|
||||
(channel-instances->manifest (list guix
|
||||
instance0 instance1
|
||||
instance2 instance3))))
|
||||
|
||||
(define entries
|
||||
(manifest-entries manifest))
|
||||
|
||||
(define (depends? drv in out)
|
||||
;; Return true if DRV depends on all of IN and none of OUT.
|
||||
(let ((lst (map derivation-input-path (derivation-inputs drv)))
|
||||
(in (map derivation-file-name in))
|
||||
(out (map derivation-file-name out)))
|
||||
(and (every (cut member <> lst) in)
|
||||
(not (any (cut member <> lst) out)))))
|
||||
|
||||
(define (lookup name)
|
||||
(run-with-store store
|
||||
(lower-object
|
||||
(manifest-entry-item
|
||||
(manifest-lookup manifest
|
||||
(manifest-pattern (name name)))))))
|
||||
|
||||
(let ((drv-guix (lookup "guix"))
|
||||
(drv0 (lookup "a"))
|
||||
(drv1 (lookup "b"))
|
||||
(drv2 (lookup "c"))
|
||||
(drv3 (lookup "d")))
|
||||
(and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
|
||||
(depends? drv0
|
||||
(list) (list drv1 drv2 drv3))
|
||||
(depends? drv1
|
||||
(list drv0) (list drv2 drv3))
|
||||
(depends? drv2
|
||||
(list drv1) (list drv0 drv3))
|
||||
(depends? drv3
|
||||
(list drv2 drv0) (list drv1))))))))
|
||||
|
||||
(test-end "channels")
|
||||
|
||||
Reference in New Issue
Block a user