zilch/lang/rust/src/registry.sld

(define-library (zilch lang rust registry)
 (import
  (scheme base) (scheme write) (scheme process-context) (scheme lazy)
  (zilch file) (zilch magic) (zilch nix drv) (zilch nix path)
  (zilch nixpkgs) (zilch vfs) (zilch zexpr)
  json
  (chicken file) (chicken process) (chicken process-context)
  (chicken base) (chicken format)
  (chicken foreign)
  (srfi 4) (srfi 152) (srfi 128) (srfi 146) (srfi 207))

 (export
   parse-lockfile fetch-and-unpack-crate
   
   lockfile-entry? lockfile-entry-name lockfile-entry-version lockfile-entry-source lockfile-entry-checksum lockfile-entry-dependencies)

 (begin
   (define yj-path (foreign-value "YJ_PATH" nonnull-c-string))

   ;; Shell out to a TOML-to-JSON parser. This will be replaced with a Nix-native solution later(tm).
   (define (parse-toml toml-to-parse)
     (define-values (read-port write-port pid) (process yj-path '("yj" "-tj")))
     (write-string toml-to-parse write-port)
     (close-output-port write-port)
     (define parsed (json-read read-port))
     (close-input-port read-port)
     ; (define-values (_ _ _) (process-wait pid))
     parsed)
  
   ;; TODO(puck): source here should probably be a record?
   ;; dependencies here is a list of (name . version-or-#f). if #f, use any version (should be unambiguous!)
   (define-record-type <lockfile-entry>
     (make-lockfile-entry name version source checksum dependencies)
     lockfile-entry?
     (name lockfile-entry-name)
     (version lockfile-entry-version)
     (source lockfile-entry-source)
     (checksum lockfile-entry-checksum)
     (dependencies lockfile-entry-dependencies))
  
   (define-record-printer (<lockfile-entry> entry out)
     (fprintf out "#<lockfile-entry ~A ~A ~A csum:~A deps:~A>"
       (lockfile-entry-name entry)
       (lockfile-entry-version entry)
       (lockfile-entry-source entry)
       (lockfile-entry-checksum entry)
       (lockfile-entry-dependencies entry)))

   ;; Read a blob from a Git repo, returning it as a bytevector.
   (define (read-git-blob repo object-hash)
     (define-values (input-port output-port _) (process "git" (list "-C" repo "cat-file" "blob" object-hash)))
     (close-output-port output-port)
     (define buf (make-bytevector 2048 0))
     (call-with-port (open-output-bytevector)
      (lambda (outport)
         (do ((read-bytes 0 (read-bytevector! buf input-port))) ((eof-object? read-bytes) (close-input-port input-port) (get-output-bytevector outport))
             (unless (eof-object? read-bytes) (write-bytevector buf outport 0 read-bytes))))))

   ;; Return the mode (dir, file, executable, symlink, gitlink) based on mode bits.
   (define (git-mode-type mode)
     (case mode
       ((#o040000) 'dir)
       ((#o100644 #o100664) 'file)
       ((#o100755) 'executable)
       ((#o120000) 'symlink)
       ((#o160000) 'gitlink)))

   ;; Read a git tree object recursively, returning a vfs object.
   (define (read-git-tree repo object-name)
     (define vfs-contents (mapping (make-default-comparator)))

     ;; Internal helper to iterate part of a tree object.
     ;; Results need to end up in vfs-contents, hence inner lambda.
     (define (read-tree obj-hash parent)
       (define-values (input-port output-port _) (process "git" (list "-C" repo "cat-file" "tree" obj-hash)))
       (close-output-port output-port)

       (define (read-until port nullval)
         (define result (bytevector))
         (do ((v #f)) ((or (eof-object? v) (eq? nullval v)) result)
           (when v
             (set! result (bytevector-append result (bytevector v))))
           (set! v (read-u8 port))))
       ;; TODO(puck): written this way to avoid misoptimizing the type of `value`.
       ;; for some reason, peek-u8/read-u8/read-bytevector are specified to only return
       ;; number/bytevector, no `eof`. this causes miscompilation if doing (eof-object? (peek-u8 port))
       (define (read-tree-entry value)
         (when (number? value)
          (let*
           ((mode (string->number (utf8->string (read-until input-port #x20)) 8))
            (name (utf8->string (read-until input-port 0)))
            (hash (bytevector->hex-string (read-bytevector 20 input-port)))
            (mode-type (git-mode-type mode)))

           (case mode-type
            ((dir)
             (read-tree hash (if (string=? parent "") name (string-append parent "/" name)))
             (set! vfs-contents (mapping-set! vfs-contents (cons parent name) 'directory)))
            ((file executable)
             (set! vfs-contents (mapping-set! vfs-contents (cons parent name) (zfile (read-git-blob repo hash) (eq? mode-type 'executable)))))
            ((symlink)
             (set! vfs-contents (mapping-set! vfs-contents (cons parent name) (zsymlink (read-git-blob repo hash)))))
            (else
             (error "unknown mode" (list obj-hash name mode-type mode)))))

          (read-tree-entry (peek-u8 input-port))))
       (read-tree-entry (peek-u8 input-port))
       (close-input-port input-port))
     (read-tree object-name "")
     (make-vfs vfs-contents))

   ;; Return the subset of the vfs that contains the Cargo.toml matching the package's name
   (define (find-matching-cargo vfs name)
     (call/cc
      (lambda (cont)
       (mapping-for-each
        (lambda (key value)
          (when (and (string=? (cdr key) "Cargo.toml") (not (eq? value 'directory)))
            (let*
             ((contents (call-with-port (store-path-open value) (lambda (port) (read-string 99999999 port))))
              (parsed (vector->list (parse-toml contents)))
              (package-pair (assoc "package" parsed))
              (package-name (and package-pair (assoc "name" (vector->list (cdr package-pair))))))
             (when (and package-name (string=? (cdr package-name) name)) (cont (vfs-subdir vfs (car key)))))))
        (vfs-contents vfs))
       #f)))
   (define (fetch-git repo url refspec name)
     (unless (directory-exists? repo)
       (create-directory repo #t)
       (let-values (((_ _ _) (process-wait (process-run "git" (list "init" "--bare" repo))))) #f))

     (define-values (_ commit-exists _) (process-wait (process-run "git" (list "-C" repo "cat-file" "-e" refspec))))
     (unless commit-exists
       (let-values (((_ _ _) (process-wait (process-run "git" (list "-C" repo "fetch" "--write-fetch-head" url refspec))))) #f))
     (define tree (read-git-tree repo (string-append refspec ":")))
     (define subdir (find-matching-cargo tree name))
     (unless subdir (error "could not find package in git repo" (list url refspec name)))
     (vfs-to-store subdir))

   (define (fetch-from-registry lockfile-entry)
     ; TODO(puck): hardcoded
     (define url (string-append "https://static.crates.io/crates/" (lockfile-entry-name lockfile-entry) "/" (lockfile-entry-version lockfile-entry) "/download"))
     (define crate-name (string-append (lockfile-entry-name lockfile-entry) "-" (lockfile-entry-version lockfile-entry) ".crate"))
     (define crate-name-path (string-append (lockfile-entry-name lockfile-entry) "-" (lockfile-entry-version lockfile-entry)))
     (define fetched-tarball (store-path-for-fod crate-name "builtin" '("builtin:fetchurl") `(("url" . ,url) ("allowSubstitutes" . "")) "sha256" (lockfile-entry-checksum lockfile-entry) #f))
     (define unpacked-tarball
       (cdar (store-path-for-drv crate-name "builtin" '("builtin:unpack-channel")
              #~(("src" . #$fetched-tarball)
                 ("allowSubstitutes" . "")
                 ("channelName" . #$crate-name-path)) '("out"))))
     #~,(string-append #$unpacked-tarball "/" #$crate-name-path))

   (define git-dir (or (get-environment-variable "XDG_CACHE_HOME") (string-append (get-environment-variable "HOME") "/.cache/zilch/git")))

   (define (fetch-and-unpack-crate lockfile-entry)
     (define src (lockfile-entry-source lockfile-entry))
     (cond
      ((string-prefix? "git+" src)
       (let* ((hash-index (string-contains-right src "#"))
              (query-index (or (string-contains src "?") hash-index)))
         (fetch-git git-dir (string-copy src 4 query-index) (string-copy src (+ 1 hash-index)) (lockfile-entry-name lockfile-entry))))
      ((equal? src "registry+https://github.com/rust-lang/crates.io-index") (fetch-from-registry lockfile-entry))
      (else (error "unknown source " lockfile-entry))))

   (define (parse-lockfile file-contents)
     (define inputs (vector->list (parse-toml file-contents)))
     (define lockfile-version (assoc "version" inputs))
     (unless (and lockfile-version (>= (cdr lockfile-version) 3)) (error "Unknown lockfile version" lockfile-version))
     (define packages (assoc "package" inputs))
     (map
       (lambda (package)
         (define alist (vector->list package))
         (define name (assoc "name" alist))
         (define version (assoc "version" alist))
         (define source (assoc "source" alist))
         (define checksum (assoc "checksum" alist))
         (define dependencies (assoc "dependencies" alist))

         (define processed-dependencies
           (if dependencies
             (map (lambda (dep)
                     (define index (string-contains dep " "))
                     (if index (cons (string-copy dep 0 index) (string-copy dep (+ index 1))) (cons dep #f))) (cdr dependencies))
             '()))
         (make-lockfile-entry (cdr name) (cdr version) (and source (cdr source)) (and checksum (hex-string->bytevector (cdr checksum))) processed-dependencies))
       (if packages (cdr packages) '())))))