derivations: Add 'graft-derivation'.

* guix/derivations.scm (graft-derivation): New procedure.
* guix/build/graft.scm: New file.
* Makefile.am (MODULES): Add it.
* tests/derivations.scm ("graft-derivation"): New test.

Makefile.am

@@ -74,6 +74,7 @@ MODULES =					\
   guix/build/svn.scm				\
   guix/build/syscalls.scm			\
   guix/build/emacs-utils.scm			\
+  guix/build/graft.scm				\
   guix/packages.scm				\
   guix/import/utils.scm				\
   guix/import/snix.scm				\

guix/build/graft.scm

@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build graft)
+  #:use-module (guix build utils)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:export (replace-store-references
+            rewrite-directory))
+
+;;; Commentary:
+;;;
+;;; This module supports "grafts".  Grafting a directory means rewriting it,
+;;; with references to some specific items replaced by references to other
+;;; store items---the grafts.
+;;;
+;;; This method is used to provide fast security updates as only the leaves of
+;;; the dependency graph need to be grafted, even when the security updates
+;;; affect a core component such as Bash or libc.  It is based on the idea of
+;;; 'replace-dependency' implemented by Shea Levy in Nixpkgs.
+;;;
+;;; Code:
+
+(define* (replace-store-references input output mapping
+                                   #:optional (store (%store-directory)))
+  "Read data from INPUT, replacing store references according to MAPPING, and
+writing the result to OUTPUT."
+  (define pattern
+    (let ((nix-base32-chars
+           '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+             #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
+             #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
+      `(,@(map char-set (string->list store))
+        ,(char-set #\/)
+        ,@(make-list 32 (list->char-set nix-base32-chars))
+        ,(char-set #\-))))
+
+  ;; We cannot use `regexp-exec' here because it cannot deal with strings
+  ;; containing NUL characters, hence 'fold-port-matches'.
+  (with-fluids ((%default-port-encoding #f))
+    (when (file-port? input)
+      (setvbuf input _IOFBF 65536))
+    (when (file-port? output)
+      (setvbuf output _IOFBF 65536))
+
+    (let* ((len     (+ 34 (string-length store)))
+           (mapping (map (match-lambda
+                          ((origin . replacement)
+                           (unless (string=? (string-drop origin len)
+                                             (string-drop replacement len))
+                             (error "invalid replacement" origin replacement))
+                           (cons (string-take origin len)
+                                 (string-take replacement len))))
+                         mapping)))
+     (fold-port-matches (lambda (string result)
+                          (match (assoc-ref mapping string)
+                            (#f
+                             (put-bytevector output (string->utf8 string)))
+                            ((= string->utf8 replacement)
+                             (put-bytevector output replacement)))
+                          #t)
+                        #f
+                        pattern
+                        input
+                        (lambda (char result)     ;unmatched
+                          (put-u8 output (char->integer char))
+                          result)))))
+
+(define* (rewrite-directory directory output mapping
+                            #:optional (store (%store-directory)))
+  "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
+file name pairs."
+  (define prefix-len
+    (string-length directory))
+
+  (define (destination file)
+    (string-append output (string-drop file prefix-len)))
+
+  (define (rewrite-leaf file stat result)
+    (case (stat:type stat)
+      ((symlink)
+       (let ((target (readlink file)))
+         (symlink (call-with-output-string
+                   (lambda (output)
+                     (replace-store-references (open-input-string target)
+                                               output mapping
+                                               store)))
+                  (destination file))))
+      ((regular)
+       (with-fluids ((%default-port-encoding #f))
+         (call-with-input-file file
+           (lambda (input)
+             (call-with-output-file (destination file)
+               (lambda (output)
+                 (replace-store-references input output mapping
+                                           store)
+                 (chmod output (stat:perms stat))))))))
+      (else
+       (error "unsupported file type" stat))))
+
+  (file-system-fold (const #t)
+                    rewrite-leaf
+                    (lambda (directory stat result) ;down
+                      (mkdir (destination directory)))
+                    (const #t)                      ;up
+                    (const #f)                      ;skip
+                    (lambda (file stat errno result) ;error
+                      (error "read error" file stat errno))
+                    #f
+                    directory
+                    lstat))
+
+;;; graft.scm ends here

guix/derivations.scm

@@ -65,6 +65,7 @@ (define-module (guix derivations)
             derivation-path->output-path
             derivation-path->output-paths
             derivation
+            graft-derivation
             map-derivation
 
             %guile-for-build
@@ -952,6 +953,64 @@ (define builder
                                   #:guile-for-build guile
                                   #:local-build? #t)))
 
+(define (graft-derivation store name drv replacements)
+  "Return a derivation called NAME, based on DRV but with all the first
+elements of REPLACEMENTS replaced by the corresponding second element.
+REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
+  ;; XXX: Someday rewrite using gexps.
+  (define mapping
+    ;; List of store item pairs.
+    (map (match-lambda
+          (((source source-outputs ...) . (target target-outputs ...))
+           (cons (if (derivation? source)
+                     (apply derivation->output-path source source-outputs)
+                     source)
+                 (if (derivation? target)
+                     (apply derivation->output-path target target-outputs)
+                     target))))
+         replacements))
+
+  (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 add-label
+    (cut cons "x" <>))
+
+  (match replacements
+    (((sources . targets) ...)
+     (build-expression->derivation store name build
+                                   #:modules '((guix build graft)
+                                               (guix build utils))
+                                   #:inputs `(("original" ,drv)
+                                              ,@(append (map add-label sources)
+                                                        (map add-label targets)))
+                                   #:outputs output-names
+                                   #:local-build? #t))))
+
 (define* (build-expression->derivation store name exp
                                        #:key
                                        (system (%current-system))

tests/derivations.scm

@@ -813,6 +813,35 @@ (define (deps path . deps)
                                      (string<? p1 p2)))))))))))))
 
 
+(test-assert "graft-derivation"
+  (let* ((build `(begin
+                   (mkdir %output)
+                   (chdir %output)
+                   (symlink %output "self")
+                   (call-with-output-file "text"
+                     (lambda (output)
+                       (format output "foo/~a/bar" ,%mkdir)))
+                   (symlink ,%bash "sh")))
+         (orig  (build-expression->derivation %store "graft" build
+                                              #:inputs `(("a" ,%bash)
+                                                         ("b" ,%mkdir))))
+         (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
+                                  `(((,%bash) . (,one))
+                                    ((,%mkdir) . (,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)
+                (string=? (readlink (string-append graft "/self")) graft))))))
+
 (test-equal "map-derivation"
   "hello"
   (let* ((joke (package-derivation %store guile-1.8))