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)

    ;; Uses the hash in a `<go-sum-line>` to return a store path containing a list of the hashes of each file,
    ;; following the https://pkg.go.dev/golang.org/x/mod/sumdb/dirhash[`dirhash`] format used by the `go.sum` files.
    (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. Uses `fetch-dirhash-for-sum` to generate the dirhash, then creates FODs
    ;; for each file based on said hash; this is then returned as a `<vfs>` structure.
    (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 subset of `vfs`, filtered down to only contain the contents of files that
    ;; Go cares about.
    (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))))

    ;; Generates a representation of the `vfs`, processed to be turned into JSON.
    ;; Primarily used by `(zilch lang go package)` to allow extracting the necessary
    ;; information of each package from a module's vfs.
    (define (vfs-to-json vfs)
      (mapping-map->list
        (lambda (k v) (list (car k) (cdr k) (if (eq? v 'directory) "" v)))
        (vfs-contents vfs)))))