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-string
    vfs-to-store vfs-append-file)

  (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-fold
         (lambda (key value acc)
           (cond
             ((string=? (car key) subdir) (mapping-set! acc (cons "" (cdr key)) value))
             ((string-prefix? subdirprefix (car key)) (mapping-set! acc (cons (string-copy (car key) subdirprefixlength) (cdr key)) value))
             (else acc)))
         (mapping (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)) (file-executable? (string-append reldir "/" name))))))))
          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))))

    (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 "/"))
        (define dirname (if split (string-copy name 0 split) ""))
        (define filename (if split (string-copy name (+ 1 split)) name))
        (unless (mapping-ref/default new-mapping (cons dirname filename) #f) (set! new-mapping (mapping-set! new-mapping (cons dirname filename) 'directory)))
        (unless (string=? dirname "") (add-parent-dir dirname)))
      (unless (string=? dirname "") (add-parent-dir dirname))
      (make-vfs new-mapping))))