summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix/nar.scm23
-rw-r--r--tests/nar.scm183
2 files changed, 169 insertions, 37 deletions
diff --git a/guix/nar.scm b/guix/nar.scm
index 9ae76ff2a9..29b57dc989 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -161,6 +161,11 @@ sub-directories of FILE as needed."
(dump f)
(write-string ")" p)))
entries)))
+ ((symlink)
+ (write-string "type" p)
+ (write-string "symlink" p)
+ (write-string "target" p)
+ (write-string (readlink f) p))
(else
(raise (condition (&message (message "ENOSYS"))
(&nar-error)))))
@@ -178,14 +183,26 @@ Restore it as FILE."
(file #f))))))
(let restore ((file file))
+ (define (read-eof-marker)
+ (match (read-string port)
+ (")" #t)
+ (x (raise
+ (condition
+ (&message (message "invalid nar end-of-file marker"))
+ (&nar-read-error (port port) (file file) (token x)))))))
+
(match (list (read-string port) (read-string port) (read-string port))
(("(" "type" "regular")
(call-with-output-file file (cut read-contents port <>))
- (match (read-string port)
- (")" #t)
+ (read-eof-marker))
+ (("(" "type" "symlink")
+ (match (list (read-string port) (read-string port))
+ (("target" target)
+ (symlink target file)
+ (read-eof-marker))
(x (raise
(condition
- (&message (message "invalid nar end-of-file marker"))
+ (&message (message "invalid symlink tokens"))
(&nar-read-error (port port) (file file) (token x)))))))
(("(" "type" "directory")
(let ((dir file))
diff --git a/tests/nar.scm b/tests/nar.scm
index 2d9bffd487..4321cbda53 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -22,10 +22,122 @@
#:use-module (rnrs io ports)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
- #:use-module (ice-9 ftw))
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match))
;; Test the (guix nar) module.
+
+;;;
+;;; File system testing tools, initially contributed to Guile, then libchop.
+;;;
+
+(define (random-file-size)
+ (define %average (* 1024 512)) ; 512 KiB
+ (define %stddev (* 1024 64)) ; 64 KiB
+ (inexact->exact
+ (max 0 (round (+ %average (* %stddev (random:normal)))))))
+
+(define (make-file-tree dir tree)
+ "Make file system TREE at DIR."
+ (let loop ((dir dir)
+ (tree tree))
+ (define (scope file)
+ (string-append dir "/" file))
+
+ (match tree
+ (('directory name (body ...))
+ (mkdir (scope name))
+ (for-each (cute loop (scope name) <>) body))
+ (('directory name (? integer? mode) (body ...))
+ (mkdir (scope name))
+ (for-each (cute loop (scope name) <>) body)
+ (chmod (scope name) mode))
+ ((file)
+ (populate-file (scope file) (random-file-size)))
+ ((file (? integer? mode))
+ (populate-file (scope file) (random-file-size))
+ (chmod (scope file) mode))
+ ((from '-> to)
+ (symlink to (scope from))))))
+
+(define (delete-file-tree dir tree)
+ "Delete file TREE from DIR."
+ (let loop ((dir dir)
+ (tree tree))
+ (define (scope file)
+ (string-append dir "/" file))
+
+ (match tree
+ (('directory name (body ...))
+ (for-each (cute loop (scope name) <>) body)
+ (rmdir (scope name)))
+ (('directory name (? integer? mode) (body ...))
+ (chmod (scope name) #o755) ; make sure it can be entered
+ (for-each (cute loop (scope name) <>) body)
+ (rmdir (scope name)))
+ ((from '-> _)
+ (delete-file (scope from)))
+ ((file _ ...)
+ (delete-file (scope file))))))
+
+(define-syntax-rule (with-file-tree dir tree body ...)
+ (dynamic-wind
+ (lambda ()
+ (make-file-tree dir 'tree))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (delete-file-tree dir 'tree))))
+
+(define (file-tree-equal? input output)
+ "Return #t if the file trees at INPUT and OUTPUT are equal."
+ (define strip
+ (cute string-drop <> (string-length input)))
+ (define sibling
+ (compose (cut string-append output <>) strip))
+ (define (file=? a b)
+ (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
+ (case (stat:type (lstat a))
+ ((regular)
+ (equal?
+ (call-with-input-file a get-bytevector-all)
+ (call-with-input-file b get-bytevector-all)))
+ ((symlink)
+ (string=? (readlink a) (readlink b)))
+ (else
+ (error "what?" (lstat a))))))
+
+ (file-system-fold (const #t)
+ (lambda (name stat result) ; leaf
+ (and result
+ (file=? name (sibling name))))
+ (lambda (name stat result) ; down
+ result)
+ (lambda (name stat result) ; up
+ result)
+ (const #f) ; skip
+ (lambda (name stat errno result)
+ (pk 'error name stat errno)
+ #f)
+ (> (stat:nlink (stat output)) 2)
+ input
+ lstat))
+
+(define (make-random-bytevector n)
+ (let ((bv (make-bytevector n)))
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (bytevector-u8-set! bv i (random 256))
+ (loop (1+ i)))
+ bv))))
+
+(define (populate-file file size)
+ (call-with-output-file file
+ (lambda (p)
+ (put-bytevector p (make-random-bytevector size)))))
+
(define (rm-rf dir)
(file-system-fold (const #t) ; enter?
(lambda (file stat result) ; leaf
@@ -39,15 +151,18 @@
dir
lstat))
+(define %test-dir
+ ;; An output directory under $top_builddir.
+ (string-append (dirname (search-path %load-path "configure"))
+ "/test-nar-" (number->string (getpid))))
+
(test-begin "nar")
(test-assert "write-file + restore-file"
(let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix"))
- (output (string-append (dirname input)
- "/test-nar-"
- (number->string (getpid))))
+ (output %test-dir)
(nar (string-append output ".nar")))
(dynamic-wind
(lambda () #t)
@@ -56,40 +171,40 @@
(cut write-file input <>))
(call-with-input-file nar
(cut restore-file <> output))
- (let* ((strip (cute string-drop <> (string-length input)))
- (sibling (compose (cut string-append output <>) strip))
- (file=? (lambda (a b)
- (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
- (case (stat:type (lstat a))
- ((regular)
- (equal?
- (call-with-input-file a get-bytevector-all)
- (call-with-input-file b get-bytevector-all)))
- ((symlink)
- (string=? (readlink a) (readlink b)))
- (else
- (error "what?" (lstat a))))))))
- (file-system-fold (const #t)
- (lambda (name stat result) ; leaf
- (and result
- (file=? name (sibling name))))
- (lambda (name stat result) ; down
- result)
- (lambda (name stat result) ; up
- result)
- (const #f) ; skip
- (lambda (name stat errno result)
- (pk 'error name stat errno)
- #f)
- (> (stat:nlink (stat output)) 2)
- input
- lstat)))
+ (file-tree-equal? input output))
(lambda ()
(false-if-exception (delete-file nar))
- (false-if-exception (rm-rf output))
- ))))
+ (false-if-exception (rm-rf output))))))
+
+(test-assert "write-file + restore-file with symlinks"
+ (let ((input (string-append %test-dir ".input")))
+ (mkdir input)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (with-file-tree input
+ (directory "root"
+ (("reg") ("exe" #o777) ("sym" -> "reg")))
+ (let* ((output %test-dir)
+ (nar (string-append output ".nar")))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (call-with-output-file nar
+ (cut write-file input <>))
+ (call-with-input-file nar
+ (cut restore-file <> output))
+ (file-tree-equal? input output))
+ (lambda ()
+ (false-if-exception (delete-file nar)))))))
+ (lambda ()
+ (rmdir input)))))
(test-end "nar")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;;; Local Variables:
+;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
+;;; End:
generated by cgit v1.2.3 (git 2.45.0) at 2024-06-03 01:23:38 +0000