X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/9fe3f11398e858f1d06120bd046cab506efc86dc..6611cabd1c3791c79ce2ff701eaf758ceacd9119:/tests/nar.scm

diff --git a/tests/nar.scm b/tests/nar.scm
index bfc71c69a8..98752f2088 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -136,8 +136,11 @@
 (define (rm-rf dir)
   (file-system-fold (const #t)                    ; enter?
                     (lambda (file stat result)    ; leaf
+                      (unless (eq? 'symlink (stat:type stat))
+                        (chmod file #o644))
                       (delete-file file))
-                    (const #t)                    ; down
+                    (lambda (dir stat result)     ; down
+                      (chmod dir #o755))
                     (lambda (dir stat result)     ; up
                       (rmdir dir))
                     (const #t)                    ; skip
@@ -214,6 +217,82 @@
       (lambda ()
         (false-if-exception (rm-rf %test-dir))))))
 
+(test-equal "write-file-tree + fold-archive"
+  '(("R" directory #f)
+    ("R/dir" directory #f)
+    ("R/dir/exe" executable "1234")
+    ("R/dir" directory-complete #f)
+    ("R/foo" regular "abcdefg")
+    ("R/lnk" symlink "foo")
+    ("R" directory-complete #f))
+
+  (let ()
+    (define-values (port get-bytevector)
+      (open-bytevector-output-port))
+    (write-file-tree "root" port
+                     #:file-type+size
+                     (match-lambda
+                       ("root"
+                        (values 'directory 0))
+                       ("root/foo"
+                        (values 'regular 7))
+                       ("root/lnk"
+                        (values 'symlink 0))
+                       ("root/dir"
+                        (values 'directory 0))
+                       ("root/dir/exe"
+                        (values 'executable 4)))
+                     #:file-port
+                     (match-lambda
+                       ("root/foo" (open-input-string "abcdefg"))
+                       ("root/dir/exe" (open-input-string "1234")))
+                     #:symlink-target
+                     (match-lambda
+                       ("root/lnk" "foo"))
+                     #:directory-entries
+                     (match-lambda
+                       ("root" '("foo" "dir" "lnk"))
+                       ("root/dir" '("exe"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (if (memq type '(regular executable))
+                                         (utf8->string
+                                          (get-bytevector-n (car contents)
+                                                            (cdr contents)))
+                                         contents)))
+                       (cons `(,file ,type ,contents)
+                             result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
+(test-equal "write-file-tree + fold-archive, flat file"
+  '(("R" regular "abcdefg"))
+
+  (let ()
+    (define-values (port get-bytevector)
+      (open-bytevector-output-port))
+    (write-file-tree "root" port
+                     #:file-type+size
+                     (match-lambda
+                       ("root" (values 'regular 7)))
+                     #:file-port
+                     (match-lambda
+                       ("root" (open-input-string "abcdefg"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (utf8->string
+                                      (get-bytevector-n (car contents)
+                                                        (cdr contents)))))
+                       (cons `(,file ,type ,contents) result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
 (test-assert "write-file supports non-file output ports"
   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
@@ -287,7 +366,12 @@
                   (cut write-file input <>))
                 (call-with-input-file nar
                   (cut restore-file <> output))
-                (file-tree-equal? input output))
+
+                (and (file-tree-equal? input output)
+                     (every (lambda (file)
+                              (canonical-file?
+                               (string-append output "/" file)))
+                            '("root" "root/reg" "root/exe"))))
               (lambda ()
                 (false-if-exception (delete-file nar))
                 (false-if-exception (rm-rf output)))))))
@@ -368,6 +452,9 @@
         (false-if-exception (rm-rf %test-dir))
         (setlocale LC_ALL locale)))))
 
+;; XXX: Tell the 'deduplicate' procedure what store we're actually using.
+(setenv "NIX_STORE" (%store-prefix))
+
 (test-assert "restore-file-set (signed, valid)"
   (with-store store
     (let* ((texts (unfold (cut >= <> 10)
@@ -399,8 +486,9 @@
   ;; their mtime and permissions were not reset.  Ensure that this bug is
   ;; gone.
   (with-store store
-    (let* ((text1 (random-text))
-           (text2 (random-text))
+    ;; Note: TEXT1 and TEXT2 must be longer than %DEDUPLICATION-MINIMUM-SIZE.
+    (let* ((text1 (string-concatenate (make-list 200 (random-text))))
+           (text2 (string-concatenate (make-list 200 (random-text))))
            (tree  `("tree" directory
                     ("a" regular (data ,text1))
                     ("b" directory