@@ -35,6 +35,7 @@
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (channel
channel?
channel-name
@@ -289,6 +290,34 @@ INSTANCE depends on."
#:commit (channel-instance-commit instance)
#:dependencies dependencies))
+(define (resolve-dependencies instances)
+ "Return a procedure that, given one of the elements of INSTANCES, returns
+list of instances it depends on."
+ (define channel-instance-name
+ (compose channel-name channel-instance-channel))
+
+ (define table ;map a name to an instance
+ (fold (lambda (instance table)
+ (vhash-consq (channel-instance-name instance)
+ instance table))
+ vlist-null
+ instances))
+
+ (define edges
+ (fold (lambda (instance edges)
+ (fold (lambda (channel edges)
+ (let ((name (channel-name channel)))
+ (match (vhash-assq name table)
+ ((_ . target)
+ (vhash-consq instance target edges)))))
+ edges
+ (channel-instance-dependencies instance)))
+ vlist-null
+ instances))
+
+ (lambda (instance)
+ (vhash-foldq* cons '() instance edges)))
+
(define (channel-instance-derivations instances)
"Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
@@ -310,27 +339,22 @@ INSTANCES."
(module-ref (resolve-interface '(gnu packages guile))
'guile-bytestructures)))
- (mlet %store-monad ((core (build-channel-instance core-instance)))
- (mapm %store-monad
- (lambda (instance)
- (if (eq? instance core-instance)
- (return core)
- (match (channel-instance-dependencies instance)
- (()
+ (define edges
+ (resolve-dependencies instances))
+
+ (define (instance->derivation instance)
+ (mcached (if (eq? instance core-instance)
+ (build-channel-instance instance)
+ (mlet %store-monad ((core (instance->derivation core-instance))
+ (deps (mapm %store-monad instance->derivation
+ (edges instance))))
(build-channel-instance instance
- (cons core dependencies)))
- (channels
- (mlet %store-monad ((dependencies-derivation
- (latest-channel-derivation
- ;; %default-channels is used here to
- ;; ensure that the core channel is
- ;; available for channels declared as
- ;; dependencies.
- (append channels %default-channels))))
- (build-channel-instance instance
- (cons dependencies-derivation
- (cons core dependencies))))))))
- instances)))
+ (cons core
+ (append deps
+ dependencies)))))
+ instance))
+
+ (mapm %store-monad instance->derivation instances))
(define (whole-package-for-legacy name modules)
"Return a full-blown Guix package for MODULES, a derivation that builds Guix
@@ -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")
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. --- guix/channels.scm | 64 ++++++++++++++++++++++++----------- tests/channels.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 126 insertions(+), 22 deletions(-)