zilch/core/src/vfs.sld

;; Contains procedures to work with a very simple virtual filesystem,
;; abstracting between local and in-store store paths.
(define-library (zilch vfs)
  (import
    (scheme base) (scheme file)
    (chicken file)
    (zilch magic) (zilch file) (zilch zexpr)
    (srfi 4) (srfi 113) (srfi 128) (srfi 146) (srfi 152))

  (export
    <vfs> 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)

  (begin
    (define (read-full-file port)
      (define buf (make-bytevector 2048 0))
      (call-with-port (open-output-bytevector)
        (lambda (outport)
          (do ((read-bytes 0 (read-bytevector! buf port))) ((eof-object? read-bytes) (get-output-bytevector outport))
              (unless (eof-object? read-bytes) (write-bytevector buf outport 0 read-bytes))))))

    ;; `contents` is a mapping whose keys are a pair (dir . filename) to file contents (e.g. zfile, or store path).
    ;; The file contents may be the symbol 'directory to indicate there's a directory.
    ;;
    ;; The root directory is specified by `dir` being an empty string. There are no trailing or leading slashes.
    (define-record-type <vfs>
      (make-vfs contents)
      vfs?
      (contents vfs-contents))

    (define (vfs-dir-files vfs dir)
      (mapping-map->list
        (lambda (k v) (cons (cdr k) v))
        (mapping-filter
          (lambda (key val)
            (and (not (eq? val 'directory)) (string=? (car key) dir)))
          (vfs-contents vfs))))

    (define (vfs-file-ref vfs dirname filename)
      (mapping-ref/default (vfs-contents vfs) (cons dirname filename) #f))

    ;; Calls the filter with the dir, filename, and contents, for each file.
    ;; If filter returns #f, the file in the vfs will be replaced by /dev/null.
    (define (vfs-dir-filter vfs filter)
      (make-vfs
        (mapping-map/monotone
          (lambda (key val)
            (if (or (eq? val 'directory) (filter (car key) (cdr key) val)) (values key val) (values key "/dev/null")))
          (make-default-comparator)
          (vfs-contents vfs))))

    ;; Calls the filter for each directory. If the filter returns #f, the directory's files are replaced with `/dev/null`.
    (define (vfs-dir-filter-all filter vfs)
      (define to-filter-out (set (make-default-comparator)))
      (mapping-for-each
        (lambda (key val)
          (when (and (eq? val 'directory) (not (filter (string-append (car key) "/" (cdr key)))))
            (set! to-filter-out (set-adjoin! to-filter-out (string-append (car key) "/" (cdr key))))))
        (vfs-contents vfs))
      (define (is-filtered dirname)
        (set-any? (lambda (v) (string=? v dirname)) to-filter-out))
      (make-vfs
        (mapping-map/monotone
          (lambda (key val)
             (if (or (eq? val 'directory) (not (is-filtered (car key)))) (values key val) (values key "/dev/null")))
          (make-default-comparator)
          (vfs-contents vfs))))

    ;; Takes a VFS and writes its directory structure into the Nix store,
    ;; returning a zdir describing the root directory.
    (define (vfs-to-store vfs)
      (define dirmap (mapping (make-default-comparator)))
      (mapping-for-each
        (lambda (k contents)
          (define dir (car k))
          (define fname (cdr k))
          (if (eq? contents 'directory)
            (set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname 'directory) v)) '()))
            (set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname (zsymlink contents)) v)) '()))))
        (vfs-contents vfs))
      (define (read-dir dirname)
        (define contents (mapping-ref/default dirmap dirname '()))
        (for-each
          (lambda (pair)
            (when (eq? (cdr pair) 'directory)
              (set-cdr! pair (read-dir (if (string=? dirname "") (car pair) (string-append dirname "/" (car pair)))))))
          contents)
        (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)))
      (define (iter-dir dirpath)
        (define reldir (string-append osdir "/" dirpath))
        (define contents (directory reldir))
        (for-each
          (lambda (name)
            (unless (string=? (string-copy name 0 1) ".")
              (if (directory-exists? (string-append reldir "/" name))
                (begin
                  (iter-dir (if (string=? dirpath "") name (string-append dirpath "/" name)))
                  (set! out (mapping-set! out (cons dirpath name) 'directory)))
                (set! out (mapping-set! out (cons dirpath name) (zfile (zexp ,(call-with-input-file (string-append reldir "/" name) read-full-file))))))))
          contents))
      (iter-dir "")
      (make-vfs out))

    (define (vfs-from-store store-path)
      (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))))))