04/04: graft: Correctly replace references near the end of the scan buffer.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 94e86a6b67c7a02f5f11358743f3b9f11997059c
Author: Ludovic Courtès <address@hidden>
Date:   Thu Aug 24 13:14:47 2017 +0200

    graft: Correctly replace references near the end of the scan buffer.
    
    Fixes <http://bugs.gnu.org/28212>.
    Reported by Leo Famulari <address@hidden>.
    
    * guix/build/graft.scm (replace-store-references): When I >= END, check
    whether WRITTEN > END and call 'get-bytevector-n!' when it is.
    * tests/grafts.scm (buffer-size): New variable.
    ("replace-store-references, <http://bugs.gnu.org/28212>"): New test.
---
 guix/build/graft.scm | 22 +++++++++++++---------
 tests/grafts.scm     | 34 +++++++++++++++++++++++++++++++++-
 2 files changed, 46 insertions(+), 10 deletions(-)

diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 16df169..3dce486 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -164,15 +164,19 @@ bytevectors to the same value."
                ;; not to unget bytes that have already been written, because
                ;; that would cause them to be written again from the next
                ;; buffer.  In practice, this case occurs when a replacement is
-               ;; made near the end of the buffer.
-               (let* ((unwritten   (- end written))
-                      (unget-size  (if (= end request-size)
-                                       (min hash-length unwritten)
-                                       0))
-                      (write-size  (- unwritten unget-size)))
-                 (put-bytevector output buffer written write-size)
-                 (unget-bytevector input buffer (+ written write-size)
-                                   unget-size)
+               ;; made near or beyond the end of the buffer.  When REPLACEMENT
+               ;; went beyond END, we consume the extra bytes from INPUT.
+               (begin
+                 (if (> written end)
+                     (get-bytevector-n! input buffer 0 (- written end))
+                     (let* ((unwritten  (- end written))
+                            (unget-size (if (= end request-size)
+                                            (min hash-length unwritten)
+                                            0))
+                            (write-size (- unwritten unget-size)))
+                       (put-bytevector output buffer written write-size)
+                       (unget-bytevector input buffer (+ written write-size)
+                                         unget-size)))
                  (loop)))))))))
 
 (define (rename-matching-files directory mapping)
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 08f05c0..abb074d 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -28,7 +28,9 @@
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
-  #:use-module (rnrs io ports))
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 vlist))
 
 (define %store
   (open-connection-for-tests))
@@ -442,4 +444,34 @@
            (and (file-exists? (string-append out "/p2/replacement"))
                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 
+(define buffer-size
+  ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
+  (expt 2 20))
+
+(test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
+  (string-append (make-string (- buffer-size 47) #\a)
+                 "/gnu/store/" (make-string 32 #\8)
+                 "-SoMeTHiNG"
+                 (list->string (map integer->char (iota 77 33))))
+
+  ;; Create input data where the right-hand-size of the dash ("-something"
+  ;; here) goes beyond the end of the internal buffer of
+  ;; 'replace-store-references'.
+  (let* ((content     (string-append (make-string (- buffer-size 47) #\a)
+                                     "/gnu/store/" (make-string 32 #\7)
+                                     "-something"
+                                     (list->string
+                                      (map integer->char (iota 77 33)))))
+         (replacement (alist->vhash
+                       `((,(make-string 32 #\7)
+                          . ,(string->utf8 (string-append
+                                            (make-string 32 #\8)
+                                            "-SoMeTHiNG")))))))
+    (call-with-output-string
+      (lambda (output)
+        ((@@ (guix build graft) replace-store-references)
+         (open-input-string content) output
+         replacement
+         "/gnu/store")))))
+
 (test-end)