puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch lang rust registry): add git support

Browse source
This commit is contained in:
puck 2025-02-14 16:45:06 +00:00
parent 47add39192
commit 5306246cdd
1 changed files with 106 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

113
lang/rust/src/registry.sld
View file

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