From patchwork Fri Jan 18 09:53:42 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 761 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 34CF516A88; Fri, 18 Jan 2019 09:54:08 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id B0C5516A7D for ; Fri, 18 Jan 2019 09:54:07 +0000 (GMT) Received: from localhost ([127.0.0.1]:35178 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gkQql-0001Q3-Ah for patchwork@mira.cbaines.net; Fri, 18 Jan 2019 04:54:07 -0500 Received: from eggs.gnu.org ([209.51.188.92]:41491) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gkQqi-0001ME-54 for guix-patches@gnu.org; Fri, 18 Jan 2019 04:54:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gkQqf-0001EU-V9 for guix-patches@gnu.org; Fri, 18 Jan 2019 04:54:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:36417) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gkQqf-0001Dx-Ps for guix-patches@gnu.org; Fri, 18 Jan 2019 04:54:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gkQqf-0001eU-Np for guix-patches@gnu.org; Fri, 18 Jan 2019 04:54:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#34122] [PATCH 1/3] channels: Don't pull from the same channel more than once. References: <20190118092938.12208-1-ludo@gnu.org> In-Reply-To: <20190118092938.12208-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 18 Jan 2019 09:54:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34122 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34122@debbugs.gnu.org Received: via spool by 34122-submit@debbugs.gnu.org id=B34122.15478052336324 (code B ref 34122); Fri, 18 Jan 2019 09:54:01 +0000 Received: (at 34122) by debbugs.gnu.org; 18 Jan 2019 09:53:53 +0000 Received: from localhost ([127.0.0.1]:35694 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gkQqX-0001du-6e for submit@debbugs.gnu.org; Fri, 18 Jan 2019 04:53:53 -0500 Received: from hera.aquilenet.fr ([185.233.100.1]:37952) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gkQqV-0001dZ-AJ for 34122@debbugs.gnu.org; Fri, 18 Jan 2019 04:53:51 -0500 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id B0B152349; Fri, 18 Jan 2019 10:53:50 +0100 (CET) X-Virus-Scanned: Debian amavisd-new at aquilenet.fr Received: from hera.aquilenet.fr ([127.0.0.1]) by localhost (hera.aquilenet.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id p2Yq1TqFOoUT; Fri, 18 Jan 2019 10:53:49 +0100 (CET) Received: from gnu.org (unknown [IPv6:2001:660:6102:320:e120:2c8f:8909:cdfe]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 6906CC39; Fri, 18 Jan 2019 10:53:49 +0100 (CET) From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 18 Jan 2019 10:53:42 +0100 Message-Id: <20190118095344.12927-1-ludo@gnu.org> X-Mailer: git-send-email 2.20.1 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: rekado@elephly.net Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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(-) 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")