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.
(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)
#: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."
;; 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.
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)))
(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)
HCoop / jackhill / guix / guix.git / commitdiff