diff --git a/core/src/vfs.sld b/core/src/vfs.sld index 3ca3e0f..f19f00b 100644 --- a/core/src/vfs.sld +++ b/core/src/vfs.sld @@ -13,6 +13,7 @@ vfs-dir-filter vfs-dir-filter-all vfs-subdir vfs-from-directory vfs-from-store + vfs-to-string vfs-to-store vfs-append-file) (begin @@ -133,13 +134,48 @@ (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)))) - + + (define (escape-ifs-string strval) + (define output-parts '()) + (define (find index) + (define next-index (string-index-right strval (lambda (ch) (or (char=? ch #\space) (char=? ch #\newline) (char=? ch #\\))) index)) + (if next-index + (begin + (set! output-parts (cons "\\" (cons (string-copy strval next-index index) output-parts))) + (find next-index)) + (set! output-parts (cons (string-copy strval 0 index) output-parts)))) + (find (string-length strval)) + (string-concatenate output-parts)) + + (define (vfs-to-string vfs) + (define output '()) + (mapping-for-each + (lambda (k v) + (define dirname (car k)) + (define filename (cdr k)) + (define path (if (string=? dirname "") filename (string-append dirname "/" filename))) + (if (eq? v 'directory) + (set! output (cons (cons 'mkdir path) output)) + (set! output (cons (cons 'copy (cons v path)) output)))) + (vfs-contents vfs)) + (define (make-string data) + (define new-output '()) + (for-each + (lambda (item) + (case (car item) + ((mkdir) (set! new-output (cons (string-append "mkdir " (escape-ifs-string (cdr item)) "\n") new-output))) + ((copy) (set! new-output (cons (string-append "copy " (escape-ifs-string (cadr item)) " " (escape-ifs-string (cddr item)) "\n") new-output))))) + data) + (string-concatenate new-output)) + + (zexp ,(make-string (zexp-unquote output)))) + ;; Returns a new VFS, with one file added. (define (vfs-append-file vfs path contents) (define split (string-contains-right path "/")) (define dirname (if split (string-copy path 0 split) "")) (define filename (if split (string-copy path (+ 1 split)) path)) - + (define new-mapping (mapping-set (vfs-contents vfs) (cons dirname filename) contents)) (define (add-parent-dir name) (define split (string-contains-right name "/"))