aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-03 23:02:46 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-03 23:16:48 +0200
commit57bdd79e485801ccf405ca7389bd099809fe5d67 (patch)
treeb0c6df4c2a0eee45d64025fb7b157671173bbde1
parentb38e97e03b92d54524953949934884828a1683c1 (diff)
downloadguix-57bdd79e485801ccf405ca7389bd099809fe5d67.tar
guix-57bdd79e485801ccf405ca7389bd099809fe5d67.tar.gz
grafts: Allow the replacement to have a different name.
* guix/build/graft.scm (replace-store-references): REPLACEMENT is now the full string, not just the hash. (rewrite-directory)[hash-mapping](valid-suffix?): Remove. (hash+suffix): Rename to... (hash+rest): ... this. Change to return the whole string as the second element of the list. Adjust 'match-lambda' expression accordingly; check whether the string length of the origin and replacement match. * tests/grafts.scm ("graft-derivation, grafted item uses a different name"): New test. * doc/guix.texi (Security Updates): Update sentence on the name/version restriction.
-rw-r--r--doc/guix.texi8
-rw-r--r--guix/build/graft.scm43
-rw-r--r--tests/grafts.scm19
3 files changed, 49 insertions, 21 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 73570277f6..9bd8b43582 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11782,10 +11782,10 @@ minute for an ``average'' package on a recent machine. Grafting is
recursive: when an indirect dependency requires grafting, then grafting
``propagates'' up to the package that the user is installing.
-Currently, the graft and the package it replaces (@var{bash-fixed} and
-@var{bash} in the example above) must have the exact same @code{name}
-and @code{version} fields. This restriction mostly comes from the fact
-that grafting works by patching files, including binary files, directly.
+Currently, the length of the name and version of the graft and that of
+the package it replaces (@var{bash-fixed} and @var{bash} in the example
+above) must be equal. This restriction mostly comes from the fact that
+grafting works by patching files, including binary files, directly.
Other restrictions may apply: for instance, when adding a graft to a
package providing a shared library, the original shared library and its
replacement must have the same @code{SONAME} and be binary-compatible.
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index f85d485554..b08b65b7cf 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -20,7 +20,6 @@
(define-module (guix build graft)
#:use-module (guix build utils)
#:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
@@ -58,7 +57,9 @@
#:optional (store (%store-directory)))
"Read data from INPUT, replacing store references according to
REPLACEMENT-TABLE, and writing the result to OUTPUT. REPLACEMENT-TABLE is a
-vhash that maps strings (original hashes) to bytevectors (replacement hashes).
+vhash that maps strings (original hashes) to bytevectors (replacement strings
+comprising the replacement hash, a dash, and a string).
+
Note: We use string keys to work around the fact that guile-2.0 hashes all
bytevectors to the same value."
@@ -130,16 +131,18 @@ bytevectors to the same value."
;; that have not yet been written.
(put-bytevector output buffer written
(- i hash-length written))
- ;; Now write the replacement hash.
+ ;; Now write the replacement string.
(put-bytevector output replacement)
;; Since the byte at position 'i' is a dash,
;; which is not a nix-base32 char, the earliest
;; position where the next hash might start is
;; i+1, and the earliest position where the
;; following dash might start is (+ i 1
- ;; hash-length). Also, we have now written up to
- ;; position 'i' in the buffer.
- (scan-from (+ i 1 hash-length) i)))
+ ;; hash-length). Also, increase the write
+ ;; position to account for REPLACEMENT.
+ (let ((len (bytevector-length replacement)))
+ (scan-from (+ i 1 len)
+ (+ i (- len hash-length))))))
;; If the byte at position 'i' is a nix-base32 char,
;; then the dash we're looking for might be as early as
;; the following byte, so we can only advance by 1.
@@ -213,26 +216,32 @@ an exception is caught."
file name pairs."
(define hash-mapping
+ ;; List of hash/replacement pairs, where the hash is a nix-base32 string
+ ;; and the replacement is a string that includes the replacement's name,
+ ;; like "r837zajjc1q8z9hph4b6860a9c05blyy-openssl-1.0.2j".
(let* ((prefix (string-append store "/"))
(start (string-length prefix))
(end (+ start hash-length)))
(define (valid-hash? h)
(every nix-base32-char? (string->list h)))
- (define (valid-suffix? s)
- (string-prefix? "-" s))
- (define (hash+suffix s)
+ (define (hash+rest s)
(and (< end (string-length s))
- (let ((hash (substring s start end))
- (suffix (substring s end)))
+ (let ((hash (substring s start end))
+ (all (substring s start)))
(and (string-prefix? prefix s)
- (valid-hash? hash)
- (valid-suffix? suffix)
- (list hash suffix)))))
+ (valid-hash? hash)
+ (eqv? #\- (string-ref s end))
+ (list hash all)))))
+
(map (match-lambda
- (((= hash+suffix (origin-hash suffix))
+ (((= hash+rest (origin-hash origin-string))
.
- (= hash+suffix (replacement-hash suffix)))
- (cons origin-hash (string->utf8 replacement-hash)))
+ (= hash+rest (replacement-hash replacement-string)))
+ (unless (= (string-length origin-string)
+ (string-length replacement-string))
+ (error "replacement length differs from the original length"
+ origin-string replacement-string))
+ (cons origin-hash (string->utf8 replacement-string)))
((origin . replacement)
(error "invalid replacement" origin replacement)))
mapping)))
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 13c56750ed..f2ff839fd8 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -80,6 +80,25 @@
(string=? (readlink (string-append grafted "/self"))
grafted))))))
+(test-assert "graft-derivation, grafted item uses a different name"
+ (let* ((build `(begin
+ (mkdir %output)
+ (chdir %output)
+ (symlink %output "self")
+ (symlink ,%bash "sh")))
+ (orig (build-expression->derivation %store "grafted" build
+ #:inputs `(("a" ,%bash))))
+ (repl (add-text-to-store %store "BaSH" "fake bash"))
+ (grafted (graft-derivation %store orig
+ (list (graft
+ (origin %bash)
+ (replacement repl))))))
+ (and (build-derivations %store (list grafted))
+ (let ((grafted (derivation->output-path grafted)))
+ (and (string=? (readlink (string-append grafted "/sh")) repl)
+ (string=? (readlink (string-append grafted "/self"))
+ grafted))))))
+
;; Make sure 'derivation-file-name' always gets to see an absolute file name.
(fluid-set! %file-port-name-canonicalization 'absolute)