mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
Add `add-to-store' with recursive directory storage.
* guix/store.scm (write-file): Implement directory recursive dump. (add-to-store): Fix the parameter list. * tests/derivations.scm (directory-contents): New procedure. ("add-to-store, recursive"): New test.
This commit is contained in:
parent
81095052a8
commit
b37eb5ede6
2 changed files with 64 additions and 23 deletions
|
@ -27,6 +27,7 @@ (define-module (guix store)
|
|||
#: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 buf (make-bytevector buf-size))
|
|||
(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 @@ (define-operation (add-text-to-store (string name) (string text)
|
|||
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)
|
||||
|
|
|
@ -21,12 +21,14 @@ (define-module (test-derivations)
|
|||
#: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 %current-system
|
|||
(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 @@ (define %store
|
|||
(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"
|
||||
|
|
Loading…
Reference in a new issue