diff --git a/core/src/vfs.sld b/core/src/vfs.sld index cdee1ac..55ddba3 100644 --- a/core/src/vfs.sld +++ b/core/src/vfs.sld @@ -5,12 +5,13 @@ (scheme base) (scheme file) (chicken file) (zilch magic) (zilch file) (zilch zexpr) - (srfi 4) (srfi 113) (srfi 128) (srfi 146)) + (srfi 4) (srfi 113) (srfi 128) (srfi 146) (srfi 152)) (export make-vfs vfs? vfs-contents vfs-dir-files vfs-file-ref vfs-dir-filter vfs-dir-filter-all + vfs-subdir vfs-from-directory vfs-from-store vfs-to-store) @@ -91,6 +92,23 @@ (zdir contents)) (read-dir "")) + ;; Creates a new VFS that is a subdirectory of the existing + ;; VFS. + (define (vfs-subdir vfs subdir) + (define subdirprefix (string-append subdir "/")) + (define subdirprefixlength (string-length subdirprefix)) + (if (string=? subdir "") + vfs + (make-vfs + (mapping-map + (lambda (key value) + (cond + ((string=? (car key) subdir) (values (cons "" (cdr key)) value)) + ((string-prefix? subdirprefix (car key)) (values (cons (string-copy (car key) subdirprefixlength) (cdr key)) value)) + (else (values)))) + (make-default-comparator) + (vfs-contents vfs))))) + ;; Generates a full VFS structure from an on-disk directory. (define (vfs-from-directory osdir) (define out (mapping (make-default-comparator))) @@ -110,6 +128,8 @@ (make-vfs out)) (define (vfs-from-store store-path) - (define osdir (store-path-realised store-path)) - ; TODO(puck): use builtin:fetchurl here instead of reimporting (requires divining a hash first) - (vfs-from-directory osdir)))) + (if (vfs? store-path) + store-path + (let ((osdir (store-path-realised store-path))) + ; TODO(puck): use builtin:fetchurl here instead of reimporting (requires divining a hash first) + (vfs-from-directory osdir))))))