diff --git a/lang/rust/src/registry.sld b/lang/rust/src/registry.sld index e14c6fc..77a657b 100644 --- a/lang/rust/src/registry.sld +++ b/lang/rust/src/registry.sld @@ -2,12 +2,12 @@ (import (scheme base) (scheme write) (scheme process-context) (scheme lazy) (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) - (zilch nixpkgs) (zilch zexpr) + (zilch nixpkgs) (zilch vfs) (zilch zexpr) json - (chicken process) + (chicken file) (chicken process) (chicken process-context) (chicken base) (chicken format) (chicken foreign) - (srfi 4) (srfi 152) (srfi 207)) + (srfi 4) (srfi 152) (srfi 128) (srfi 146) (srfi 207)) (export parse-lockfile fetch-and-unpack-crate @@ -43,10 +43,97 @@ (lockfile-entry-source entry) (lockfile-entry-checksum entry) (lockfile-entry-dependencies entry))) - - (define (fetch-and-unpack-crate lockfile-entry) - (unless (equal? (lockfile-entry-source lockfile-entry) "registry+https://github.com/rust-lang/crates.io-index") (error "unknown source " lockfile-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 (_ _ _) (process-wait (process-run "git" (list "-C" repo "fetch" "--write-fetch-head" url refspec)))) + (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")) @@ -58,6 +145,18 @@ ("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))