nix-community/dream2nix
1
1
Fork 0
mirror of https://github.com/nix-community/dream2nix.git synced 2024-12-25 23:41:42 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #454 from zainab-ali/racket-git-repo

Browse Source 
Support git url dependencies in Racket dream2nix generation
This commit is contained in:
DavHau 2023-01-24 22:03:47 +07:00 committed by GitHub
commit 029dcc6358
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 199 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

187
src/subsystems/racket/translators/racket-impure/generate-dream-lock.rkt
View File

@ -1,7 +1,10 @@
#lang racket/base #lang racket/base
(require json) (require json)
(require pkg/lib)
(require pkg/name)
(require racket/file) (require racket/file)
(require racket/function)
(require racket/match) (require racket/match)
(require racket/list) (require racket/list)
(require racket/set) (require racket/set)
@ -16,8 +19,85 @@
;; that we traverse foo-lib, and that subsequently generating the ;; that we traverse foo-lib, and that subsequently generating the
;; foo-lib dream-lock requires repeating the same traversal of foo-lib. How can this be avoided? ;; foo-lib dream-lock requires repeating the same traversal of foo-lib. How can this be avoided?
(define-logger dream2nix)
;; TODO: no effort is made to handle cycles right now
(define (dfs graph u dependency-subgraph)
(if (hash-has-key? dependency-subgraph u)
dependency-subgraph
(let ([destinations (hash-ref graph u)])
(foldl (curry dfs graph)
(hash-set dependency-subgraph u destinations)
destinations))))
(define (dependencies dir)
(let ([info-procedure (get-info/full dir)]
[ignore-error (lambda (_) '())])
(append (with-handlers ([exn:fail? ignore-error])
(info-procedure 'deps))
(with-handlers ([exn:fail? ignore-error])
(info-procedure 'build-deps)))))
(define dependency->name+type
(match-lambda [(or (cons pkg-name _) pkg-name) (package-source->name+type pkg-name #f)]))
(define (dependency->name dep)
(let-values ([(name _) (dependency->name+type dep)]) name))
(define (fetch-git-repositories dep graph)
(define (package-source->git-url dep)
(let-values ([(_ type) (dependency->name+type dep)])
(and (eq? type 'git-url) dep)))
(define git-url (package-source->git-url dep))
(if git-url
(let-values ([(name dir checksum _del _paths) (pkg-stage
(pkg-desc git-url 'git-url #f #f #f)
#:use-cache? #t)])
(log-dream2nix-info "Staging git repository ~a in temporary directory ~a" git-url dir)
(define deps (dependencies dir))
(define next-graph (hash-set graph name
(make-immutable-hash
`([dependencies . ,(map dependency->name deps)]
[checksum . ,checksum]
[url . ,git-url]))))
(foldl fetch-git-repositories next-graph deps))
graph))
(define (remote-pkg->source name url rev)
(define (url->source url)
(let* ([source-with-removed-http-or-git-double-slash (regexp-replace #rx"^(?:git|http)://" url "https://")]
[left-trimmed-source (string-trim source-with-removed-http-or-git-double-slash "git+" #:right? #f)]
[maybe-match-path (regexp-match #rx"\\?path=([^#]+)" left-trimmed-source)]
[trimmed-source (regexp-replace #rx"(?:/tree/.+)?(?:\\?path=.+)?$" left-trimmed-source "")])
(cons `(url . ,trimmed-source)
(match maybe-match-path
[(list _match dir)
`((dir . ,(regexp-replace* #rx"%2F" dir "/")))]
[_ '()]))))
(cons (string->symbol name)
(make-immutable-hash
`((0.0.0 . ,(make-immutable-hash
(append
(url->source url)
`((rev . ,rev)
(type . "git")
;; TODO: sha256?
))))))))
(define (local-pkg->source name path)
(list (cons (string->symbol name)
(make-immutable-hash
`((0.0.0 . ,(make-immutable-hash
`((type . "path")
(path . ,path)))))))))
(define (generate-dream-lock pkgs-all-path) (define (generate-dream-lock pkgs-all-path)
(letrec ([src-path (getenv "RACKET_SOURCE")] (log-dream2nix-info "Generating dream lock.")
(let* ([src-path (getenv "RACKET_SOURCE")]
[rel-path (getenv "RACKET_RELPATH")] [rel-path (getenv "RACKET_RELPATH")]
[package-path (simplify-path (cleanse-path (build-path src-path (if (string=? rel-path "") [package-path (simplify-path (cleanse-path (build-path src-path (if (string=? rel-path "")
'same 'same
@ -28,14 +108,17 @@
(path->string (path->string
(match/values (split-path package-path) (match/values (split-path package-path)
((_base subdir _must-be-dir?) subdir))))] ((_base subdir _must-be-dir?) subdir))))]
[_ (log-dream2nix-info "Reading package catalog from file ~a." pkgs-all-path)]
[pkgs-all (with-input-from-file pkgs-all-path read)] [pkgs-all (with-input-from-file pkgs-all-path read)]
[pkg-in-stdlib? (lambda (pkg-name) [pkg-in-stdlib? (lambda (pkg-name)
(or ;; Some people add racket itself as a dependency for some reason (or ;; Some people add racket itself as a dependency for some reason
(string=? pkg-name "racket") (string=? pkg-name "racket")
(let ([pkg (hash-ref pkgs-all pkg-name #f)])
(and pkg
(ormap (lambda (tag) (ormap (lambda (tag)
;; XXX: would prefer to use memq, but tag is mutable for some reason ;; XXX: would prefer to use memq, but tag is mutable for some reason
(member tag '("main-distribution" "main-tests"))) (member tag '("main-distribution" "main-tests")))
(hash-ref (hash-ref pkgs-all pkg-name) 'tags))))] (hash-ref pkg 'tags))))))]
[dep-alist-from-catalog (hash-map pkgs-all [dep-alist-from-catalog (hash-map pkgs-all
(match-lambda** (match-lambda**
[(name (hash-table ('dependencies dependencies))) [(name (hash-table ('dependencies dependencies)))
@ -43,48 +126,53 @@
(cons name external-deps))]))] (cons name external-deps))]))]
[compute-overridden-dep-lists [compute-overridden-dep-lists
(lambda (name dir) (lambda (name dir)
(let ([info-procedure (get-info/full dir)])
(and info-procedure
(cons name (cons name
(remove-duplicates (remove-duplicates
(filter-not pkg-in-stdlib? (filter-not pkg-in-stdlib?
(map (match-lambda (map dependency->name
[(or (cons pkg-name _) pkg-name) (dependencies dir))))))]
pkg-name]) [paths-from-repo
(append (with-handlers ([exn:fail? (lambda (_) '())])
(info-procedure 'deps))
(with-handlers ([exn:fail? (lambda (_) '())])
(info-procedure 'build-deps))))))))))]
[dep-list-overrides
;; XXX: this probably doesn't capture every case since ;; XXX: this probably doesn't capture every case since
;; Racket doesn't seem to enforce much structure in a ;; Racket doesn't seem to enforce much structure in a
;; multi-package repo, but it accounts for the only cases ;; multi-package repo, but it accounts for the only cases
;; that a sane person would choose ;; that a sane person would choose
(if (string=? rel-path "") (if (string=? rel-path "")
(list (compute-overridden-dep-lists package-name package-path)) (list (cons package-name package-path))
(let* ([sibling-paths (filter directory-exists? (let* ([info-exists? (lambda (dir) (get-info/full dir))]
(directory-list parent-path #:build? #t))] [sibling-paths (filter info-exists?
[names-of-sibling-paths (map (lambda (p) (filter directory-exists?
(directory-list parent-path #:build? #t)))]
[_ (log-dream2nix-info "Found ~a sibling packages." (length sibling-paths))]
[_ (for-each (lambda (path)
(log-dream2nix-info "Found sibling package: ~a." path))
sibling-paths)]
[dir-name (lambda (p)
;; XXX: maybe not very DRY ;; XXX: maybe not very DRY
(path->string (path->string
(match/values (split-path p) (match/values (split-path p)
((_base dir-fragment _must-be-dir?) dir-fragment)))) ((_base dir-fragment _must-be-dir?) dir-fragment))))])
sibling-paths)]) (map (lambda (p) (cons (dir-name p) p)) sibling-paths)))]
(filter-map compute-overridden-dep-lists [dep-list-overrides
names-of-sibling-paths (map (match-lambda [(cons name path) (compute-overridden-dep-lists name path)]) paths-from-repo)]
sibling-paths)))]
[names-of-overridden-packages (apply set (map car dep-list-overrides))] [names-of-overridden-packages (apply set (map car dep-list-overrides))]
[git-repositories
(let* ([deps (append-map (lambda (path) (dependencies (cdr path))) paths-from-repo)]
[git-repositories (foldl fetch-git-repositories #hash() deps)]
[names (hash-keys git-repositories)])
(log-dream2nix-info "Found ~a direct dependencies on git repositories." (length names))
(for-each (lambda (name)
(log-dream2nix-info "Found git repository dependency: ~a." name))
names)
git-repositories)]
[dep-alist-from-git (hash-map git-repositories
(match-lambda**
[(name (hash-table ('dependencies dependencies)))
(let ([external-deps (filter-not pkg-in-stdlib? dependencies)])
(cons name external-deps))]))]
[graph (make-immutable-hash (append dep-alist-from-catalog [graph (make-immutable-hash (append dep-alist-from-catalog
dep-list-overrides))] dep-list-overrides
;; TODO: no effort is made to handle cycles right now dep-alist-from-git))]
[dfs (lambda (u dependency-subgraph) [dependency-subgraph (dfs graph package-name (make-immutable-hash))]
(if (hash-has-key? dependency-subgraph u)
dependency-subgraph
(let ([destinations (hash-ref graph u)])
(foldl dfs
(hash-set dependency-subgraph u destinations)
destinations))))]
[dependency-subgraph (dfs package-name (make-immutable-hash))]
[generic (make-immutable-hash [generic (make-immutable-hash
`((subsystem . "racket") `((subsystem . "racket")
(location . ,rel-path) (location . ,rel-path)
@ -101,36 +189,21 @@
(hash-table (hash-table
('source_url url))))) ('source_url url)))))
('checksum rev))) ('checksum rev)))
(let* ([source-with-removed-http-or-git-double-slash (regexp-replace #rx"^(?:git|http)://" url "https://")] (remote-pkg->source name url rev)]))]
[left-trimmed-source (string-trim source-with-removed-http-or-git-double-slash "git+" #:right? #f)] [sources-from-git
[maybe-match-path (regexp-match #rx"\\?path=([^#]+)" left-trimmed-source)] (hash-map git-repositories
[trimmed-source (regexp-replace #rx"(?:/tree/.+)?(?:\\?path=.+)?$" left-trimmed-source "")]) (match-lambda**
(cons (string->symbol name) [(name (hash-table
(make-immutable-hash ('url url)
`((0.0.0 . ,(make-immutable-hash ('checksum rev)))
(append (match maybe-match-path (remote-pkg->source name url rev)]))]
[(list _match dir)
`((dir . ,(regexp-replace* #rx"%2F" dir "/")))]
[_ '()])
`((url . ,trimmed-source)
(rev . ,rev)
(type . "git")
;; TODO: sha256?
))))))))]))]
[sources-from-repo (if (string=? rel-path "") [sources-from-repo (if (string=? rel-path "")
(list (cons (string->symbol package-name) (local-pkg->source package-name src-path)
(make-immutable-hash
`((0.0.0 . ,(make-immutable-hash
`((type . "path")
(path . ,src-path))))))))
(set-map names-of-overridden-packages (set-map names-of-overridden-packages
(lambda (name) (lambda (name)
(cons (string->symbol name) (local-pkg->source name (path->string (build-path parent-path (string-append-immutable name "/")))))))]
(make-immutable-hash
`((0.0.0 . ,(make-immutable-hash
`((type . "path")
(path . ,(path->string (build-path parent-path (string-append-immutable name "/")))))))))))))]
[sources-hash-table (make-immutable-hash (append sources-from-catalog [sources-hash-table (make-immutable-hash (append sources-from-catalog
sources-from-git
sources-from-repo))] sources-from-repo))]
[sources (make-immutable-hash (hash-map dependency-subgraph [sources (make-immutable-hash (hash-map dependency-subgraph
(lambda (name _v) (lambda (name _v)