mirror of
https://github.com/nix-community/dream2nix.git
synced 2024-12-26 16:03:38 +03:00
Merge pull request #454 from zainab-ali/racket-git-repo
Support git url dependencies in Racket dream2nix generation
This commit is contained in:
DavHau
GitHub
commit
029dcc6358
@ -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,134 +19,204 @@
|
|||||||
;; 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.")
|
||||||
[rel-path (getenv "RACKET_RELPATH")]
|
(let* ([src-path (getenv "RACKET_SOURCE")]
|
||||||
[package-path (simplify-path (cleanse-path (build-path src-path (if (string=? rel-path "")
|
[rel-path (getenv "RACKET_RELPATH")]
|
||||||
'same
|
[package-path (simplify-path (cleanse-path (build-path src-path (if (string=? rel-path "")
|
||||||
rel-path))))]
|
'same
|
||||||
[parent-path (simplify-path (cleanse-path (build-path package-path 'up)))]
|
rel-path))))]
|
||||||
[package-name (if (string=? rel-path "")
|
[parent-path (simplify-path (cleanse-path (build-path package-path 'up)))]
|
||||||
(getenv "RACKET_PKG_MAYBE_NAME")
|
[package-name (if (string=? rel-path "")
|
||||||
(path->string
|
(getenv "RACKET_PKG_MAYBE_NAME")
|
||||||
(match/values (split-path package-path)
|
(path->string
|
||||||
((_base subdir _must-be-dir?) subdir))))]
|
(match/values (split-path package-path)
|
||||||
[pkgs-all (with-input-from-file pkgs-all-path read)]
|
((_base subdir _must-be-dir?) subdir))))]
|
||||||
[pkg-in-stdlib? (lambda (pkg-name)
|
[_ (log-dream2nix-info "Reading package catalog from file ~a." pkgs-all-path)]
|
||||||
(or ;; Some people add racket itself as a dependency for some reason
|
[pkgs-all (with-input-from-file pkgs-all-path read)]
|
||||||
(string=? pkg-name "racket")
|
[pkg-in-stdlib? (lambda (pkg-name)
|
||||||
(ormap (lambda (tag)
|
(or ;; Some people add racket itself as a dependency for some reason
|
||||||
;; XXX: would prefer to use memq, but tag is mutable for some reason
|
(string=? pkg-name "racket")
|
||||||
(member tag '("main-distribution" "main-tests")))
|
(let ([pkg (hash-ref pkgs-all pkg-name #f)])
|
||||||
(hash-ref (hash-ref pkgs-all pkg-name) 'tags))))]
|
(and pkg
|
||||||
[dep-alist-from-catalog (hash-map pkgs-all
|
(ormap (lambda (tag)
|
||||||
(match-lambda**
|
;; XXX: would prefer to use memq, but tag is mutable for some reason
|
||||||
[(name (hash-table ('dependencies dependencies)))
|
(member tag '("main-distribution" "main-tests")))
|
||||||
(let ([external-deps (filter-not pkg-in-stdlib? dependencies)])
|
(hash-ref pkg 'tags))))))]
|
||||||
(cons name external-deps))]))]
|
[dep-alist-from-catalog (hash-map pkgs-all
|
||||||
[compute-overridden-dep-lists
|
(match-lambda**
|
||||||
(lambda (name dir)
|
[(name (hash-table ('dependencies dependencies)))
|
||||||
(let ([info-procedure (get-info/full dir)])
|
(let ([external-deps (filter-not pkg-in-stdlib? dependencies)])
|
||||||
(and info-procedure
|
(cons name external-deps))]))]
|
||||||
(cons name
|
[compute-overridden-dep-lists
|
||||||
(remove-duplicates
|
(lambda (name dir)
|
||||||
(filter-not pkg-in-stdlib?
|
(cons name
|
||||||
(map (match-lambda
|
(remove-duplicates
|
||||||
[(or (cons pkg-name _) pkg-name)
|
(filter-not pkg-in-stdlib?
|
||||||
pkg-name])
|
(map dependency->name
|
||||||
(append (with-handlers ([exn:fail? (lambda (_) '())])
|
(dependencies dir))))))]
|
||||||
(info-procedure 'deps))
|
[paths-from-repo
|
||||||
(with-handlers ([exn:fail? (lambda (_) '())])
|
;; XXX: this probably doesn't capture every case since
|
||||||
(info-procedure 'build-deps))))))))))]
|
;; Racket doesn't seem to enforce much structure in a
|
||||||
[dep-list-overrides
|
;; multi-package repo, but it accounts for the only cases
|
||||||
;; XXX: this probably doesn't capture every case since
|
;; that a sane person would choose
|
||||||
;; Racket doesn't seem to enforce much structure in a
|
(if (string=? rel-path "")
|
||||||
;; multi-package repo, but it accounts for the only cases
|
(list (cons package-name package-path))
|
||||||
;; that a sane person would choose
|
(let* ([info-exists? (lambda (dir) (get-info/full dir))]
|
||||||
(if (string=? rel-path "")
|
[sibling-paths (filter info-exists?
|
||||||
(list (compute-overridden-dep-lists package-name package-path))
|
(filter directory-exists?
|
||||||
(let* ([sibling-paths (filter directory-exists?
|
(directory-list parent-path #:build? #t)))]
|
||||||
(directory-list parent-path #:build? #t))]
|
[_ (log-dream2nix-info "Found ~a sibling packages." (length sibling-paths))]
|
||||||
[names-of-sibling-paths (map (lambda (p)
|
[_ (for-each (lambda (path)
|
||||||
;; XXX: maybe not very DRY
|
(log-dream2nix-info "Found sibling package: ~a." path))
|
||||||
(path->string
|
sibling-paths)]
|
||||||
(match/values (split-path p)
|
[dir-name (lambda (p)
|
||||||
((_base dir-fragment _must-be-dir?) dir-fragment))))
|
;; XXX: maybe not very DRY
|
||||||
sibling-paths)])
|
(path->string
|
||||||
(filter-map compute-overridden-dep-lists
|
(match/values (split-path p)
|
||||||
names-of-sibling-paths
|
((_base dir-fragment _must-be-dir?) dir-fragment))))])
|
||||||
sibling-paths)))]
|
(map (lambda (p) (cons (dir-name p) p)) sibling-paths)))]
|
||||||
[names-of-overridden-packages (apply set (map car dep-list-overrides))]
|
[dep-list-overrides
|
||||||
[graph (make-immutable-hash (append dep-alist-from-catalog
|
(map (match-lambda [(cons name path) (compute-overridden-dep-lists name path)]) paths-from-repo)]
|
||||||
dep-list-overrides))]
|
[names-of-overridden-packages (apply set (map car dep-list-overrides))]
|
||||||
;; TODO: no effort is made to handle cycles right now
|
[git-repositories
|
||||||
[dfs (lambda (u dependency-subgraph)
|
(let* ([deps (append-map (lambda (path) (dependencies (cdr path))) paths-from-repo)]
|
||||||
(if (hash-has-key? dependency-subgraph u)
|
[git-repositories (foldl fetch-git-repositories #hash() deps)]
|
||||||
dependency-subgraph
|
[names (hash-keys git-repositories)])
|
||||||
(let ([destinations (hash-ref graph u)])
|
(log-dream2nix-info "Found ~a direct dependencies on git repositories." (length names))
|
||||||
(foldl dfs
|
(for-each (lambda (name)
|
||||||
(hash-set dependency-subgraph u destinations)
|
(log-dream2nix-info "Found git repository dependency: ~a." name))
|
||||||
destinations))))]
|
names)
|
||||||
[dependency-subgraph (dfs package-name (make-immutable-hash))]
|
git-repositories)]
|
||||||
[generic (make-immutable-hash
|
[dep-alist-from-git (hash-map git-repositories
|
||||||
`((subsystem . "racket")
|
(match-lambda**
|
||||||
(location . ,rel-path)
|
[(name (hash-table ('dependencies dependencies)))
|
||||||
(sourcesAggregatedHash . ,(json-null))
|
(let ([external-deps (filter-not pkg-in-stdlib? dependencies)])
|
||||||
(defaultPackage . ,package-name)
|
(cons name external-deps))]))]
|
||||||
(packages . ,(make-immutable-hash `((,(string->symbol package-name) . "0.0.0"))))))]
|
[graph (make-immutable-hash (append dep-alist-from-catalog
|
||||||
[sources-from-catalog
|
dep-list-overrides
|
||||||
(hash-map pkgs-all
|
dep-alist-from-git))]
|
||||||
(match-lambda**
|
[dependency-subgraph (dfs graph package-name (make-immutable-hash))]
|
||||||
[(name (hash-table
|
[generic (make-immutable-hash
|
||||||
('versions
|
`((subsystem . "racket")
|
||||||
|
(location . ,rel-path)
|
||||||
|
(sourcesAggregatedHash . ,(json-null))
|
||||||
|
(defaultPackage . ,package-name)
|
||||||
|
(packages . ,(make-immutable-hash `((,(string->symbol package-name) . "0.0.0"))))))]
|
||||||
|
[sources-from-catalog
|
||||||
|
(hash-map pkgs-all
|
||||||
|
(match-lambda**
|
||||||
|
[(name (hash-table
|
||||||
|
('versions
|
||||||
|
(hash-table
|
||||||
|
('default
|
||||||
(hash-table
|
(hash-table
|
||||||
('default
|
('source_url url)))))
|
||||||
(hash-table
|
('checksum rev)))
|
||||||
('source_url url)))))
|
(remote-pkg->source name url rev)]))]
|
||||||
('checksum rev)))
|
[sources-from-git
|
||||||
(let* ([source-with-removed-http-or-git-double-slash (regexp-replace #rx"^(?:git|http)://" url "https://")]
|
(hash-map git-repositories
|
||||||
[left-trimmed-source (string-trim source-with-removed-http-or-git-double-slash "git+" #:right? #f)]
|
(match-lambda**
|
||||||
[maybe-match-path (regexp-match #rx"\\?path=([^#]+)" left-trimmed-source)]
|
[(name (hash-table
|
||||||
[trimmed-source (regexp-replace #rx"(?:/tree/.+)?(?:\\?path=.+)?$" left-trimmed-source "")])
|
('url url)
|
||||||
(cons (string->symbol name)
|
('checksum rev)))
|
||||||
(make-immutable-hash
|
(remote-pkg->source name url rev)]))]
|
||||||
`((0.0.0 . ,(make-immutable-hash
|
[sources-from-repo (if (string=? rel-path "")
|
||||||
(append (match maybe-match-path
|
(local-pkg->source package-name src-path)
|
||||||
[(list _match dir)
|
(set-map names-of-overridden-packages
|
||||||
`((dir . ,(regexp-replace* #rx"%2F" dir "/")))]
|
(lambda (name)
|
||||||
[_ '()])
|
(local-pkg->source name (path->string (build-path parent-path (string-append-immutable name "/")))))))]
|
||||||
`((url . ,trimmed-source)
|
[sources-hash-table (make-immutable-hash (append sources-from-catalog
|
||||||
(rev . ,rev)
|
sources-from-git
|
||||||
(type . "git")
|
sources-from-repo))]
|
||||||
;; TODO: sha256?
|
[sources (make-immutable-hash (hash-map dependency-subgraph
|
||||||
))))))))]))]
|
(lambda (name _v)
|
||||||
[sources-from-repo (if (string=? rel-path "")
|
(cons (string->symbol name) (hash-ref sources-hash-table (string->symbol name))))))]
|
||||||
(list (cons (string->symbol package-name)
|
[dream-lock (make-immutable-hash
|
||||||
(make-immutable-hash
|
`((_generic . ,generic)
|
||||||
`((0.0.0 . ,(make-immutable-hash
|
(sources . ,sources)
|
||||||
`((type . "path")
|
(_subsystem . ,(make-immutable-hash))
|
||||||
(path . ,src-path))))))))
|
(dependencies . ,(make-immutable-hash
|
||||||
(set-map names-of-overridden-packages
|
(hash-map dependency-subgraph
|
||||||
(lambda (name)
|
(lambda (name dep-list)
|
||||||
(cons (string->symbol name)
|
(cons (string->symbol name)
|
||||||
(make-immutable-hash
|
(make-immutable-hash `((0.0.0 . ,(map (lambda (dep-name) (list dep-name "0.0.0")) dep-list)))))))))))])
|
||||||
`((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-from-repo))]
|
|
||||||
[sources (make-immutable-hash (hash-map dependency-subgraph
|
|
||||||
(lambda (name _v)
|
|
||||||
(cons (string->symbol name) (hash-ref sources-hash-table (string->symbol name))))))]
|
|
||||||
[dream-lock (make-immutable-hash
|
|
||||||
`((_generic . ,generic)
|
|
||||||
(sources . ,sources)
|
|
||||||
(_subsystem . ,(make-immutable-hash))
|
|
||||||
(dependencies . ,(make-immutable-hash
|
|
||||||
(hash-map dependency-subgraph
|
|
||||||
(lambda (name dep-list)
|
|
||||||
(cons (string->symbol name)
|
|
||||||
(make-immutable-hash `((0.0.0 . ,(map (lambda (dep-name) (list dep-name "0.0.0")) dep-list)))))))))))])
|
|
||||||
(make-parent-directory* (getenv "RACKET_OUTPUT_FILE"))
|
(make-parent-directory* (getenv "RACKET_OUTPUT_FILE"))
|
||||||
(with-output-to-file (getenv "RACKET_OUTPUT_FILE")
|
(with-output-to-file (getenv "RACKET_OUTPUT_FILE")
|
||||||
(lambda () (write-json dream-lock))
|
(lambda () (write-json dream-lock))
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user