M Makefile.am => Makefile.am +1 -0
@@ 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 \
A guix/build/graft.scm => guix/build/graft.scm +130 -0
@@ 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
M guix/derivations.scm => guix/derivations.scm +59 -0
@@ 65,6 65,7 @@
derivation-path->output-path
derivation-path->output-paths
derivation
+ graft-derivation
map-derivation
%guile-for-build
@@ 952,6 953,64 @@ they can refer to each other."
#: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))
M tests/derivations.scm => tests/derivations.scm +29 -0
@@ 813,6 813,35 @@ Deriver: ~a~%"
(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))