me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2014-10-07 23:23:09 +02:00
parent 3c762a13bf
commit fb59e275dd
4 changed files with 219 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

130
guix/build/graft.scm 100644
View File

@ -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

59
guix/derivations.scm
View File

@ -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))

29
tests/derivations.scm
View File

@ -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))