nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Ludovic Courtès 2019-01-17 16:57:53 +01:00
parent ff8a66bc61
commit ed75bdf35c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 126 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
guix/channels.scm
View File

@ -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

84
tests/channels.scm
View File

@ -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")