zilch/lang/go/src/vfs.sld

;; Contains go-specific procedures to work with VFSes.
(define-library (zilch lang go vfs)
  (import
    (scheme base) (scheme write) (scheme file) (scheme process-context) (scheme lazy)
    (chicken file)
    (zilch magic) (zilch file) (zilch zexpr)
    (zilch nix drv) (zilch nix path) (zilch nixpkgs)
    (zilch vfs)
    (json)
    (chicken base) (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)
    (zilch vfs))

  (export vfs-from-dirhash vfs-filter-for-go-package vfs-to-json)

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

    (foreign-declare "#include \"dirhash_source.h\"")
    (define dirhash-generator
      (delay (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
      (delay (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)

    ;; 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" #~(#$(force 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" #~(#$(force 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))

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