rekahsoft/guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

grafts: Allow the replacement to have a different name.

Browse Source 
* 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.
This commit is contained in:
Ludovic Courtès 2016-10-03 23:02:46 +02:00
parent b38e97e03b
commit 57bdd79e48
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 49 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
doc/guix.texi
View File

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

43
guix/build/graft.scm
View File

@ -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 @@ (define* (replace-store-references input output replacement-table
#: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 @@ (define request-size (expt 2 20)) ; 1 MiB
;; 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 @@ (define* (rewrite-directory directory output mapping
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)))

19
tests/grafts.scm
View File

@ -80,6 +80,25 @@ (define %mkdir
(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)