01/03: grafts: Allow the replacement to have a different name.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 57bdd79e485801ccf405ca7389bd099809fe5d67
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 3 23:02:46 2016 +0200

    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.
---
 doc/guix.texi        |    8 ++++----
 guix/build/graft.scm |   43 ++++++++++++++++++++++++++-----------------
 tests/grafts.scm     |   19 +++++++++++++++++++
 3 files changed, 49 insertions(+), 21 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7357027..9bd8b43 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
address@hidden 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 f85d485..b08b65b 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 13c5675..f2ff839 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)