diff options
| -rw-r--r-- | guix/store.scm | 56 | ||||
| -rw-r--r-- | tests/derivations.scm | 31 |
2 files changed, 64 insertions, 23 deletions
diff --git a/guix/store.scm b/guix/store.scm index 1ea4d16894..1e36657d05 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) #:export (nix-server? nix-server-major-version nix-server-minor-version @@ -178,25 +179,38 @@ (define (write-file f p) (define %archive-version-1 "nix-archive-1") - (let ((s (lstat f))) - (write-string %archive-version-1 p) - (write-string "(" p) - (case (stat:type s) - ((regular) - (write-string "type" p) - (write-string "regular" p) - (if (not (zero? (logand (stat:mode s) #o100))) - (begin - (write-string "executable" p) - (write-string "" p))) - (write-contents f p) - (write-string ")" p)) - ((directory) - (write-string "type" p) - (write-string "directory" p) - (error "ENOSYS")) - (else - (error "ENOSYS"))))) + (write-string %archive-version-1 p) + + (let dump ((f f)) + (let ((s (lstat f))) + (write-string "(" p) + (case (stat:type s) + ((regular) + (write-string "type" p) + (write-string "regular" p) + (if (not (zero? (logand (stat:mode s) #o100))) + (begin + (write-string "executable" p) + (write-string "" p))) + (write-contents f p)) + ((directory) + (write-string "type" p) + (write-string "directory" p) + (let ((entries (remove (cut member <> '("." "..")) + (scandir f)))) + (for-each (lambda (e) + (let ((f (string-append f "/" e))) + (write-string "entry" p) + (write-string "(" p) + (write-string "name" p) + (write-string e p) + (write-string "node" p) + (dump f) + (write-string ")" p))) + entries))) + (else + (error "ENOSYS"))) + (write-string ")" p)))) (define-syntax write-arg (syntax-rules (integer boolean file string string-list) @@ -349,9 +363,9 @@ store-path) (define-operation (add-to-store (string basename) - (integer algo) - (boolean sha256-and-recursive?) + (boolean fixed?) ; obsolete, must be #t (boolean recursive?) + (string hash-algo) (file file-name)) "Add the contents of FILE-NAME under BASENAME to the store." store-path) diff --git a/tests/derivations.scm b/tests/derivations.scm index e2e82e54b3..eb2f360b2a 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -21,12 +21,14 @@ #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix utils) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) - #:use-module (ice-9 rdelim)) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw)) (define %current-system ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL. @@ -35,6 +37,24 @@ (define %store (false-if-exception (open-connection))) +(define (directory-contents dir) + "Return an alist representing the contents of DIR." + (define prefix-len (string-length dir)) + (sort (file-system-fold (const #t) ; enter? + (lambda (path stat result) ; leaf + (alist-cons (string-drop path prefix-len) + (call-with-input-file path + get-bytevector-all) + result)) + (lambda (path stat result) result) ; down + (lambda (path stat result) result) ; up + (lambda (path stat result) result) ; skip + (lambda (path stat errno result) result) ; error + '() + dir) + (lambda (e1 e2) + (string<? (car e1) (car e2))))) + (test-begin "derivations") (test-assert "parse & export" @@ -46,7 +66,14 @@ (and (equal? b1 b2) (equal? d1 d2)))) -(test-skip (if %store 0 3)) +(test-skip (if %store 0 4)) + +(test-assert "add-to-store, recursive" + (let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm"))) + (drv (add-to-store %store "dir-tree-test" #t #t "sha256" dir))) + (and (eq? 'directory (stat:type (stat drv))) + (equal? (directory-contents dir) + (directory-contents drv))))) (test-assert "derivation with no inputs" (let ((builder (add-text-to-store %store "my-builder.sh" |