diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/build/graft.scm | 130 | ||||
| -rw-r--r-- | guix/derivations.scm | 59 | ||||
| -rw-r--r-- | tests/derivations.scm | 29 |
4 files changed, 219 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index eba34af4a9..e623978fc9 100644 --- a/Makefile.am +++ b/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 \ diff --git a/guix/build/graft.scm b/guix/build/graft.scm new file mode 100644 index 0000000000..55f0f9410d --- /dev/null +++ b/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 diff --git a/guix/derivations.scm b/guix/derivations.scm index 5ca516aa28..a9b2c5c79d 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -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)) diff --git a/tests/derivations.scm b/tests/derivations.scm index 855b059d16..48d12990e6 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -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)) |