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.

2 files changed, 126 insertions, 22 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index cd8a0131bd..b9ce2aa024 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -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
diff --git a/tests/channels.scm b/tests/channels.scm
index f3fc383ac3..7df1b8c5fe 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -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")