From ed75bdf35ca494496cdbc7a06b414e1f08e70cac Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 17 Jan 2019 16:57:53 +0100
Subject: 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.
---
 tests/channels.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 82 insertions(+), 2 deletions(-)

(limited to 'tests/channels.scm')

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 @@ (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
   (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 @@ (define read-channel-metadata
                                    '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")
-- 
cgit v1.2.3