Re: Grafts

[ludo@gnu.org (Ludovic Courtès)]

[-- Attachment #1: Type: text/plain, Size: 794 bytes --]

The current status of ‘wip-grafts’ is that it works, there’s no
performance issue, etc.

However, the ‘graft-derivation’ procedure is not recursive: it grafts
the derivation you give it, but doesn’t graft its dependencies.  Thus,
only direct references are grafted, which isn’t so great:

  $ guix gc -R $(guix build glib) | grep bash
  /gnu/store/8fmgslrivicy54azysmaab3z1srid773-bash-4.3.27  <--+--- the ungrafted bash
  /gnu/store/3yiqz9wmwx6b7hpbapg5q39sjx33kh0j-bash-4.3.27  <--’
  /gnu/store/yl1rp2b8i2qwgxja3d09xc24ffk9sjmr-bash-4.3.27  <------ the grafted bash

Changing ‘graft-derivation’ to work recursively and perform well is a
bit challenging.

I’m posting the naive patch I have here, in case someone can look at it
before me.

Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 5631 bytes --]

	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
+     (($ <derivation-input> 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
     ((($ <graft> 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))