201 lines
9.9 KiB
Scheme
201 lines
9.9 KiB
Scheme
;; Procedures to parse lockfiles, and fetch crates from lockfile entries.
|
|
(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? lockfile-entry-name
|
|
lockfile-entry-version lockfile-entry-source
|
|
lockfile-entry-checksum lockfile-entry-dependencies)
|
|
|
|
(begin
|
|
(define yj (delay (let ((v (cdr (assoc "out" (nixpkgs "yj"))))) #~,(string-append #$v "/bin/yj"))))
|
|
(define (parse-toml toml-to-parse)
|
|
(define store-path
|
|
(cdar
|
|
(store-path-for-ca-drv*
|
|
"parse-toml" "x86_64-linux"
|
|
'("/bin/sh" "-c" "$yj -tj < $in > $out")
|
|
`(("in" . ,(zfile toml-to-parse))
|
|
("yj" . ,(force yj)))
|
|
'("out"))))
|
|
(call-with-port (store-path-open store-path) json-read))
|
|
|
|
;; The contents of a single lockfile entry.
|
|
;;
|
|
;; - `name`: The name of the crate
|
|
;; - `version`: The version of the crate.
|
|
;; - `source`: The source of the crate, as raw URL from the `Cargo.lock`.
|
|
;; - `checksum`: A bytevector containing the sha256 of the `.crate` file, if
|
|
;; one is available.
|
|
;; - `dependencies`: A list of dependencies for this crate. Each dependency
|
|
;; is a pair `(crate-name . crate-version)`, where `crate-version` is only
|
|
;; set if there is more than one version of the depended crate in the
|
|
;; lockfile.
|
|
(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")))
|
|
|
|
;; Fetch a crate from the internet. Supports the `crates.io` registry source,
|
|
;; as well as `git` dependencies. Returns a store path.
|
|
(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))))
|
|
|
|
;; Parse a `Cargo.lock`, returning a list of ``<lockfile-entry>``s.
|
|
(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) '())))))
|