zilch/lang/go/src/vfs.sld

;; Contains procedures to work with a very simple virtual filesystem,
;; abstracting between local and in-store store paths.
;;
;; A VFS is defined as a vector containing pairs consisting of the directory's
;; name, with a forward slash prefixed and postfixed (e.g. `/` or `/foo/bar/`).
;; Each pair then contains another vector, mapping filename to any value that
;; can be used as a z-expression (e.g. `store-path-for-fod` or `zfile`).
(define-library (zilch lang go vfs)
  (import
    (scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
    (chicken file)
    (zilch magic) (zilch file) (zilch zexpr)
    (zilch nix drv) (zilch nix path) (zilch nixpkgs)
    (json)
    (chicken base) (chicken format) (chicken foreign)
    (scheme char)
    (srfi 4) (srfi 113) (srfi 128) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
    (zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go sum) (zilch lang go fetch)
    (chicken foreign))

  (export vfs? vfs-dir-files vfs-file-ref vfs-dir-filter vfs-dir-filter-all vfs-from-dirhash vfs-from-directory vfs-filter-for-go-package vfs-to-store vfs-to-json)

  (begin
    ;; `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))))

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

    (foreign-declare "#include \"dirhash_source.h\"")

    (define dirhash-generator
      (go-package-link
        (go-package-compile "main"
          (map go-stdlib-ref '("archive/zip" "crypto/sha256" "fmt" "io" "os" "sort"))
          (list (cons "main.go" (zfile (foreign-value "dirhash_source" nonnull-c-string)))))))

    (foreign-declare "#include \"unzip_one_source.h\"")
    (define unpack-zip
      (go-package-link
        (go-package-compile "main"
          (map go-stdlib-ref '("archive/zip" "io" "os"))
          (list (cons "main.go" (zfile (foreign-value "unzip_one_source" nonnull-c-string)))))))

    (define (rewrite-go-package-name-for-url name)
      (define out "")
      (string-for-each (lambda (ch)
                           (if (char-upper-case? ch) (set! out (string-append out (string #\! (char-downcase ch)))) (set! out (string-append out (string ch))))) name)
      out)
   
    ;; 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 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 ""))

    ;; Reads a dirhash from a `go.sum` line. This prefetches the module from
    ;; the go module proxy, and then generates the dirhash without unpacking
    ;; said module file.
    (define (fetch-dirhash-for-sum sum-line)
      (when (go-sum-path sum-line) (error "go.sum line is invalid for fetch-dirhash-for-sum" sum-line))
      (define url (string-append "https://proxy.golang.org/" (rewrite-go-package-name-for-url (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
      (define known (fetch-with-known-url "module.zip" url))
      (store-path-for-fod "module" "x86_64-linux" #~(#$dirhash-generator) #~(("src" . #$known)) "sha256" (go-sum-hash sum-line) #f))

    ;; Generates a full VFS structure from a module as described by a `go.sum`
    ;; line.
    (define (vfs-from-dirhash sum-line)
      (define dirhash-file (fetch-dirhash-for-sum sum-line))
      (define url (string-append "https://proxy.golang.org/" (rewrite-go-package-name-for-url (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
      (define zip (fetch-with-known-url "module.zip" url))
      (define lines '())
      (define prefix-length (string-length (string-append (go-sum-module sum-line) "@" (go-sum-version sum-line) "/")))
      (call-with-port (store-path-open dirhash-file)
        (lambda (port)
          (do ((line "" (read-line port)) (hash #f) (file #f))
              ((eof-object? line) #f)
              (unless (string=? "" line)
                (set! hash (hex-string->bytevector (string-copy line 0 64)))
                (set! file (string-copy line 66))
                (set! lines (cons (cons file hash) lines))))))
      (define output (mapping (make-default-comparator)))
      (define (create-parent-dirs dirname)
        (define second-to-last-slash (string-index-right dirname (lambda (c) (char=? c #\/))))
        (when second-to-last-slash
          (set! output (mapping-set! output (cons (string-copy dirname 0 second-to-last-slash) (string-copy dirname (+ second-to-last-slash 1))) 'directory))
          (create-parent-dirs (string-copy dirname 0 second-to-last-slash)))
        (unless (or second-to-last-slash (string=? dirname "")) (set! output (mapping-set! output (cons "" dirname) 'directory))))
      (for-each
        ; (path . hash)
        (lambda (pair)
          (define file-path (string-copy (car pair) prefix-length))
          (define hash (cdr pair))

          (define last-slash (string-index-right file-path (lambda (c) (char=? c #\/))))
          (define dirname "")
          (define filename file-path)
          (when last-slash
            (set! dirname (string-copy file-path 0 last-slash))
            (set! filename (string-copy file-path (+ last-slash 1))))

          (define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" hash #f))

          ; Skip files we know for sure won't be used.
          ; TODO(puck): this should be moved to vfs-filter-for-go-package?
          (unless (or (string-contains dirname "/_") (string-contains dirname "/.") (string-contains dirname "/testdata/") (char=? #\. (string-ref filename 0)) (char=? #\_ (string-ref filename 0)))
            (create-parent-dirs dirname)
            (set! output (mapping-set! output (cons dirname filename) file))))
        lines)
      (make-vfs output))

    ;; 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 #~,(call-with-input-file (string-append reldir "/" name) read-full-file)))))))
          contents))
      (iter-dir "")
      (make-vfs out))

    ;; List extracted from go src/go/build/build.go.
    (define good-extensions '("go" "c" "cc" "cpp" "cxx" "m" "h" "hh" "hpp" "hxx" "f" "F" "for" "f90" "s" "S" "sx" "swig" "swigcxx" "syso"))
    (define (extract-extension name i)
      (cond ((char=? (string-ref name i) #\.) (string-copy name (+ i 1)))
            ((= i 0) #f)
            (else (extract-extension name (- i 1)))))

    ;; Returns a VFS, filtered down to only contain the contents of files that
    ;; will be read during the processing of Go packages.
    (define (vfs-filter-for-go-package vfs)
      (vfs-dir-filter vfs
        (lambda (dir fname contents)
          (define extension (extract-extension fname (- (string-length fname) 1)))
          (member extension good-extensions))))

    (define (vfs-to-json vfs)
      (mapping-map->list
        (lambda (k v) (list (car k) (cdr k) (if (eq? v 'directory) "" v)))
        (vfs-contents vfs)))))