From mboxrd@z Thu Jan 1 00:00:00 1970 From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) Subject: Re: Grafts Date: Fri, 17 Oct 2014 23:42:18 +0200 Message-ID: <87k33y1ih1.fsf@gnu.org> References: <87a950igwi.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:45207) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XfFHw-00039d-3m for guix-devel@gnu.org; Fri, 17 Oct 2014 17:42:29 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XfFHn-0002gg-1v for guix-devel@gnu.org; Fri, 17 Oct 2014 17:42:20 -0400 Received: from hera.aquilenet.fr ([2a01:474::1]:34413) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XfFHm-0002gX-Mq for guix-devel@gnu.org; Fri, 17 Oct 2014 17:42:10 -0400 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id E2CC516F3 for ; Fri, 17 Oct 2014 23:42:09 +0200 (CEST) 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 zPtCMWWiayVE for ; Fri, 17 Oct 2014 23:42:09 +0200 (CEST) Received: from pluto (reverse-83.fdn.fr [80.67.176.83]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 71E32E7 for ; Fri, 17 Oct 2014 23:42:09 +0200 (CEST) In-Reply-To: <87a950igwi.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Mon, 13 Oct 2014 09:10:37 +0200") List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: Guix-devel --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable The current status of =E2=80=98wip-grafts=E2=80=99 is that it works, there= =E2=80=99s no performance issue, etc. However, the =E2=80=98graft-derivation=E2=80=99 procedure is not recursive:= it grafts the derivation you give it, but doesn=E2=80=99t graft its dependencies. Th= us, only direct references are grafted, which isn=E2=80=99t so great: $ guix gc -R $(guix build glib) | grep bash /gnu/store/8fmgslrivicy54azysmaab3z1srid773-bash-4.3.27 <--+--- the ungr= afted bash /gnu/store/3yiqz9wmwx6b7hpbapg5q39sjx33kh0j-bash-4.3.27 <--=E2=80=99 /gnu/store/yl1rp2b8i2qwgxja3d09xc24ffk9sjmr-bash-4.3.27 <------ the graf= ted bash Changing =E2=80=98graft-derivation=E2=80=99 to work recursively and perform= well is a bit challenging. I=E2=80=99m posting the naive patch I have here, in case someone can look a= t it before me. Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch Content-Disposition: inline Modified guix/derivations.scm diff --git a/guix/derivations.scm b/guix/derivations.scm index 17c83e9..632bf8e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1007,40 +1009,51 @@ applied." target)))) grafts)) - (define outputs - (match (derivation-outputs drv) - (((names . outputs) ...) - (map derivation-output-path outputs)))) - - (define output-names - (match (derivation-outputs drv) - (((names . outputs) ...) - names))) - - (define build - `(begin - (use-modules (guix build graft) - (guix build utils) - (ice-9 match)) - - (let ((mapping ',mapping)) - (for-each (lambda (input output) - (format #t "rewriting '~a' to '~a'...~%" input output) - (rewrite-directory input output - `((,input . ,output) - ,@mapping))) - ',outputs - (match %outputs - (((names . files) ...) - files)))))) + (define input-mapping + (match-lambda + (($ path sub-drv) + (let ((orig (call-with-input-file path read-derivation))) + (cons orig + (graft-derivation store (derivation-name orig) orig grafts + #:guile guile + #:system system)))))) (define add-label (cut cons "x" <>)) (match grafts ((($ sources source-outputs targets target-outputs) ...) - (let ((sources (zip sources source-outputs)) - (targets (zip targets target-outputs))) + (let* ((sources (zip sources source-outputs)) + (targets (zip targets target-outputs)) + (inputs (map input-mapping (derivation-inputs drv))) + (drv (pk 'm (map-derivation store drv inputs)))) + (define outputs + (match (derivation-outputs drv) + (((names . outputs) ...) + (map derivation-output-path outputs)))) + + (define output-names + (match (derivation-outputs drv) + (((names . outputs) ...) + names))) + + (define build + `(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (let ((mapping ',mapping)) + (for-each (lambda (input output) + (format #t "rewriting '~a' to '~a'...~%" input output) + (rewrite-directory input output + `((,input . ,output) + ,@mapping))) + ',outputs + (match %outputs + (((names . files) ...) + files)))))) + (build-expression->derivation store name build #:system system #:guile-for-build guile Modified tests/derivations.scm diff --git a/tests/derivations.scm b/tests/derivations.scm index a69114a..608a7f6 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -851,6 +851,42 @@ Deriver: ~a~%" (string=? (readlink (string-append graft "/sh")) one) (string=? (readlink (string-append graft "/self")) graft)))))) +(test-assert "graft-derivation, recursive" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (dep (build-expression->derivation %store "dep" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (orig (build-expression->derivation %store "graft" + `(symlink + (assoc-ref %build-inputs "dep") + %output) + #:inputs `(("dep" ,dep)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (graft (graft-derivation %store "graft" orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list graft)) + (let ((two (derivation->output-path two)) + (graft (derivation->output-path graft))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append graft "/text") + get-string-all)) + (string=? (readlink (string-append graft "/sh")) one)))))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) --=-=-=--