zilch/lang/go/src/vfs.sld

(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 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-from-dirhash vfs-from-directory filter-vfs filter-vfs-for-package-reading 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))))))

    (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-name 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)
   
    (define (vfs-to-store vfs)
      (define dirmap (mapping (make-default-comparator)))
      (vector-for-each
        (lambda (pair)
          (define key (car pair))
          (define separator (if (string=? key "/") 0 (string-index-right key (lambda (ch) (char=? ch #\/)) 0 (- (string-length key) 1))))
          (unless (string=? key "/")
            (let
              ((dirname (string-copy key 0 (+ 1 separator)))
               (fname (string-copy key (+ 1 separator) (- (string-length key) 1))))
              (set! dirmap (mapping-set! dirmap dirname (cons (cons fname key) (mapping-ref/default dirmap dirname '())))))))
        vfs)
      (define (translate-dir name)
        (define files (vector-any (lambda (f) (and (string=? (car f) name) (cdr f))) vfs))
        (define dirs (mapping-ref/default dirmap name '()))
        (zdir (append
                (map (lambda (kv) (cons (car kv) (zsymlink (cdr kv)))) (vector->list files))
                (map (lambda (k) (cons (car k) (translate-dir (cdr k)))) dirs))))
      (translate-dir "/"))


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

    (define (vfs-from-dirhash sum-line)
      (define dirhash-file (fetch-dirhash-for-sum sum-line))
      (define url (string-append "https://proxy.golang.org/" (rewrite-name (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 dirs '())
      (for-each
        (lambda (pair)
          (define fpath (string-copy (car pair) prefix-length))
          (define slashindex (string-index-right fpath (lambda (c) (char=? c #\/))))
          (define dirname "/")
          (define filename fpath)
          (when slashindex
            (set! dirname (string-append "/" (string-copy fpath 0 slashindex) "/"))
            (set! filename (string-copy fpath (+ slashindex 1))))

          (define dir (assoc dirname dirs))
          (define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" (cdr pair) #f))
          (unless dir
             (set! dirs (cons (list dirname) dirs))
             (set! dir (car dirs)))

          ; Skip files we know for sure won't be used.
          (unless (or (string-contains dirname "/_") (string-contains dirname "/.") (string-contains dirname "/testdata/") (char=? #\. (string-ref filename 0)) (char=? #\_ (string-ref filename 0)))
            (set-cdr! dir (cons (cons filename file) (cdr dir)))))
        lines)
      (list->vector (map (lambda (pair) (cons (car pair) (list->vector (cdr pair)))) dirs)))

    (define (vfs-from-directory osdir)
      (define iter-dir #f)
      (define output '())
      (set! iter-dir
        (lambda (dirpath)
          (define reldir (string-append osdir "/" dirpath))
          (define files '())
          (define contents (directory (string-append osdir dirpath)))
          (for-each
            (lambda (name)
              (unless (string=? (string-copy name 0 1) ".")
                (if (directory-exists? (string-append reldir "/" name))
                    (iter-dir (string-append dirpath "/" name))
                    (set! files (cons (cons name (zfile #~,(call-with-input-file (string-append reldir "/" name) read-full-file))) files)))))
            contents)
          (set! output (cons (cons (string-append dirpath "/") (list->vector files)) output))))
      (iter-dir "")
      (list->vector output))

    (define (filter-vfs vfs filter)
      (vector-map
        (lambda (dir)
          (cons (car dir)
            (vector-map
              (lambda (pair)
                (if (filter (car dir) (car pair))
                    (cons (car pair) (cdr pair))
                    (cons (car pair) "/dev/null")))
              (cdr dir))))
        vfs))

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

    (define (filter-vfs-for-package-reading vfs)
      (filter-vfs vfs
        (lambda (dir fname)
          (define extension (extract-extension fname (- (string-length fname) 1)))
          (member extension good-extensions))))))