d8f9820ef3
A package catalog now supplies information about a package's modules and dependencies, so propagate it when copying a catalog, make the information accessible via `raco pkg catalog-show', and so on.
1987 lines
74 KiB
Racket
1987 lines
74 KiB
Racket
#lang racket/base
|
|
(require net/url
|
|
json
|
|
openssl/sha1
|
|
racket/contract
|
|
racket/match
|
|
racket/path
|
|
racket/file
|
|
setup/link
|
|
setup/pack
|
|
setup/unpack
|
|
setup/dirs
|
|
racket/port
|
|
racket/list
|
|
racket/function
|
|
racket/dict
|
|
racket/set
|
|
racket/string
|
|
file/untgz
|
|
file/tar
|
|
file/zip
|
|
file/unzip
|
|
setup/getinfo
|
|
setup/dirs
|
|
racket/format
|
|
version/utils
|
|
syntax/modcollapse
|
|
"name.rkt"
|
|
"util.rkt"
|
|
(prefix-in db: "db.rkt"))
|
|
|
|
(define current-pkg-scope
|
|
(make-parameter 'user))
|
|
(define current-pkg-scope-version
|
|
(make-parameter (version)))
|
|
(define current-pkg-error
|
|
(make-parameter (lambda args (apply error 'pkg args))))
|
|
(define current-no-pkg-db
|
|
(make-parameter #f))
|
|
(define current-pkg-catalogs
|
|
(make-parameter #f))
|
|
|
|
(define (pkg-error . rest)
|
|
(apply (current-pkg-error) rest))
|
|
|
|
(define (format-list l)
|
|
(if (null? l)
|
|
" [none]"
|
|
(apply string-append
|
|
(for/list ([v (in-list l)])
|
|
(format "\n ~a" v)))))
|
|
|
|
(define (log-exn x what)
|
|
(log-pkg-error (~a "failure ~a\n"
|
|
" error: ~s")
|
|
what
|
|
(exn-message x)))
|
|
|
|
(struct pkg-desc (source type name auto?))
|
|
|
|
(define (path->bytes* pkg)
|
|
(cond
|
|
[(path? pkg)
|
|
(path->bytes pkg)]
|
|
[(string? pkg)
|
|
(path->bytes (string->path pkg))]
|
|
[(bytes? pkg)
|
|
pkg]))
|
|
|
|
(define (directory-path-no-slash pkg)
|
|
(bytes->path (regexp-replace* #rx#"/$" (path->bytes* pkg) #"")))
|
|
|
|
(define (directory-list* d)
|
|
(append-map
|
|
(λ (pp)
|
|
(define p (build-path d pp))
|
|
(if (directory-exists? p)
|
|
(map (curry build-path pp)
|
|
(directory-list* p))
|
|
(list pp)))
|
|
(directory-list d)))
|
|
|
|
(define (simple-form-path* p)
|
|
(path->string (simple-form-path p)))
|
|
|
|
(define (untar pkg pkg-dir #:strip-components [strip-components 0])
|
|
(make-directory* pkg-dir)
|
|
(untgz pkg #:dest pkg-dir #:strip-count strip-components))
|
|
|
|
(define (download-file! url file #:fail-okay? [fail-okay? #f])
|
|
(with-handlers
|
|
([exn:fail?
|
|
(λ (x)
|
|
(unless fail-okay?
|
|
(raise x)))])
|
|
(make-parent-directory* file)
|
|
(log-pkg-debug "\t\tDownloading ~a to ~a" (url->string url) file)
|
|
(call-with-output-file file
|
|
(λ (op)
|
|
(call/input-url+200
|
|
url
|
|
(λ (ip) (copy-port ip op)))))))
|
|
|
|
(define (pkg-dir)
|
|
(build-path (case (current-pkg-scope)
|
|
[(installation) (find-lib-dir)]
|
|
[(user)
|
|
(build-path (find-system-path 'addon-dir) (current-pkg-scope-version))]
|
|
[(shared)
|
|
(find-system-path 'addon-dir)]
|
|
[else (error "unknown package scope")])
|
|
"pkgs"))
|
|
(define (pkg-config-file)
|
|
(build-path (pkg-dir) "config.rktd"))
|
|
(define (pkg-db-file)
|
|
(build-path (pkg-dir) "pkgs.rktd"))
|
|
(define (pkg-installed-dir)
|
|
(build-path (pkg-dir) "installed"))
|
|
(define (pkg-lock-file)
|
|
(make-lock-file-name (pkg-db-file)))
|
|
|
|
(define (link-version-regexp)
|
|
(case (current-pkg-scope)
|
|
[(installation shared) #f]
|
|
[(user) (regexp (regexp-quote (version)))]
|
|
[else (error "unknown package scope")]))
|
|
|
|
(define (make-metadata-namespace)
|
|
(make-base-empty-namespace))
|
|
|
|
(define (get-metadata metadata-ns pkg-dir key get-default
|
|
#:checker [checker void])
|
|
(define get-info
|
|
(with-handlers ([exn:fail? (λ (x)
|
|
(log-exn x "getting info")
|
|
#f)])
|
|
(get-info/full pkg-dir #:namespace metadata-ns)))
|
|
(define v
|
|
(if get-info
|
|
(get-info key get-default)
|
|
(get-default)))
|
|
(checker v)
|
|
v)
|
|
|
|
(define (package-collections pkg-dir metadata-ns)
|
|
(for/list ([d (directory-list pkg-dir)]
|
|
#:when (directory-exists? (build-path pkg-dir d))
|
|
#:when (std-filter d))
|
|
d))
|
|
|
|
(define (package-collection-directories pkg-dir metadata-ns)
|
|
(for/list ([c (in-list (package-collections pkg-dir metadata-ns))])
|
|
(build-path pkg-dir c)))
|
|
|
|
(define (collection-equal? a b)
|
|
(equal? (if (path? a) a (string->path a))
|
|
(if (path? b) b (string->path b))))
|
|
|
|
(define (check-dependencies deps)
|
|
(unless (and (list? deps)
|
|
(for/and ([dep (in-list deps)])
|
|
(define (package-source? dep)
|
|
(and (string? dep)
|
|
(package-source->name dep)))
|
|
(define (version? s)
|
|
(and (string? s)
|
|
(valid-version? s)))
|
|
(or (package-source? dep)
|
|
(and (list? dep)
|
|
(= 2 (length dep))
|
|
(package-source? (car dep))
|
|
(version? (cadr dep)))
|
|
(and (list? dep)
|
|
((length dep) . >= . 1)
|
|
(odd? (length dep))
|
|
(package-source? (car dep))
|
|
(let loop ([saw (hash)] [dep (cdr dep)])
|
|
(cond
|
|
[(null? dep) #t]
|
|
[(hash-ref saw (car dep) #f) #f]
|
|
[else
|
|
(define kw (car dep))
|
|
(define val (cadr dep))
|
|
(and
|
|
(cond
|
|
[(eq? kw '#:version) (version? val)]
|
|
[(eq? kw '#:platform)
|
|
(or (string? val)
|
|
(regexp? val)
|
|
(memq val '(unix windows macosx)))]
|
|
[else #f])
|
|
(loop (hash-set saw (car dep) #t)
|
|
(cddr dep)))]))))))
|
|
(pkg-error (~a "invalid `deps' specification\n"
|
|
" specification: ~e")
|
|
deps)))
|
|
|
|
(define (dependency->name dep)
|
|
(package-source->name
|
|
(dependency->source dep)))
|
|
|
|
(define (dependency->source dep)
|
|
(if (string? dep)
|
|
dep
|
|
(car dep)))
|
|
|
|
(define (dependency->version dep)
|
|
(cond
|
|
[(string? dep) #f]
|
|
[(null? (cdr dep)) #f]
|
|
[(keyword? (cadr dep))
|
|
(dependency-lookup '#:version dep)]
|
|
[else (cadr dep)]))
|
|
|
|
(define (dependency-lookup kw dep)
|
|
(cond
|
|
[(string? dep) #f]
|
|
[(null? (cdr dep)) #f]
|
|
[(keyword? (cadr dep))
|
|
(define p (member kw (cdr dep)))
|
|
(and p (cadr p))]
|
|
[else #f]))
|
|
|
|
(define (dependency-this-platform? dep)
|
|
(define p (dependency-lookup '#:platform dep))
|
|
(if p
|
|
(if (symbol? p)
|
|
(eq? p (system-type))
|
|
(let ([s (path->string (system-library-subpath #f))])
|
|
(if (regexp? p)
|
|
(regexp-match? p s)
|
|
(equal? p s))))
|
|
#t))
|
|
|
|
(define pkg-lock-held (make-parameter #f))
|
|
|
|
(define (with-pkg-lock* read-only? t)
|
|
(define mode (if read-only? 'shared 'exclusive))
|
|
(define held-mode (pkg-lock-held))
|
|
(if (or (eq? mode held-mode)
|
|
(eq? 'exclusive held-mode))
|
|
(t)
|
|
(let ([d (pkg-dir)])
|
|
(unless read-only? (make-directory* d))
|
|
(if (directory-exists? d)
|
|
;; If the directory exists, assume that a lock file is
|
|
;; available or creatable:
|
|
(call-with-file-lock/timeout
|
|
#f
|
|
mode
|
|
(lambda ()
|
|
(parameterize ([pkg-lock-held mode])
|
|
(t)))
|
|
(λ () (pkg-error (~a "could not acquire package lock\n"
|
|
" lock file: ~a")
|
|
(pkg-lock-file)))
|
|
#:lock-file (pkg-lock-file))
|
|
;; Directory does not exist; we must be in read-only mode.
|
|
;; Run `t' under the claim that no database is available
|
|
;; (in case the database is created concurrently):
|
|
(parameterize ([current-no-pkg-db #t])
|
|
(parameterize ([pkg-lock-held mode])
|
|
(t)))))))
|
|
(define-syntax-rule (with-pkg-lock e ...)
|
|
(with-pkg-lock* #f (λ () e ...)))
|
|
(define-syntax-rule (with-pkg-lock/read-only e ...)
|
|
(with-pkg-lock* #t (λ () e ...)))
|
|
|
|
(define (maybe-append lists)
|
|
(and (for/and ([v (in-list lists)]) (not (eq? v 'all)))
|
|
(apply append lists)))
|
|
|
|
(define (read-pkg-cfg/def k)
|
|
(define c (read-pkg-cfg))
|
|
(hash-ref c k
|
|
(λ ()
|
|
(match k
|
|
["catalogs"
|
|
(list "https://pkg.racket-lang.org"
|
|
"https://planet-compat.racket-lang.org")]))))
|
|
|
|
(define (pkg-config-catalogs)
|
|
(with-pkg-lock/read-only
|
|
(read-pkg-cfg/def "catalogs")))
|
|
|
|
(define (pkg-catalogs)
|
|
(or (current-pkg-catalogs)
|
|
(map string->url (read-pkg-cfg/def "catalogs"))))
|
|
|
|
(define (db-path? p)
|
|
(regexp-match? #rx"[.]sqlite$" (path->bytes p)))
|
|
|
|
(define (catalog-dispatch i server db dir)
|
|
(cond
|
|
[(equal? "file" (url-scheme i))
|
|
(define path (url->path i))
|
|
(cond
|
|
[(db-path? path)
|
|
(parameterize ([db:current-pkg-catalog-file path])
|
|
(db))]
|
|
[(directory-exists? path) (dir path)])]
|
|
[else (server i)]))
|
|
|
|
(define (add-version-query addr/no-query)
|
|
(struct-copy url addr/no-query
|
|
[query (append
|
|
(url-query addr/no-query)
|
|
(list
|
|
(cons 'version (version))))]))
|
|
|
|
(define (package-catalog-lookup pkg details?)
|
|
(or
|
|
(for/or ([i (in-list (pkg-catalogs))])
|
|
(catalog-dispatch
|
|
i
|
|
;; Server:
|
|
(lambda (i)
|
|
(define addr (add-version-query
|
|
(combine-url/relative i (format "pkg/~a" pkg))))
|
|
(log-pkg-debug "resolving via ~a" (url->string addr))
|
|
(read-from-server
|
|
'package-catalog-lookup
|
|
addr
|
|
(lambda (v) (and (hash? v)
|
|
(for/and ([k (in-hash-keys v)])
|
|
(symbol? k))))
|
|
(lambda (s) #f)))
|
|
;; Local database:
|
|
(lambda ()
|
|
(define pkgs (db:get-pkgs #:name pkg))
|
|
(and (pair? pkgs)
|
|
(db-pkg-info (car pkgs) details?)))
|
|
;; Local directory:
|
|
(lambda (path)
|
|
(define pkg-path (build-path path "pkg" pkg))
|
|
(and (file-exists? pkg-path)
|
|
(call-with-input-file* pkg-path read)))))
|
|
(pkg-error (~a "cannot find package on catalogs\n"
|
|
" package: ~a")
|
|
pkg)))
|
|
|
|
(define (db-pkg-info pkg details?)
|
|
(if details?
|
|
(let ([tags (db:get-pkg-tags (db:pkg-name pkg)
|
|
(db:pkg-catalog pkg))]
|
|
[mods (db:get-pkg-modules (db:pkg-name pkg)
|
|
(db:pkg-catalog pkg)
|
|
(db:pkg-checksum pkg))]
|
|
[deps (db:get-pkg-dependencies (db:pkg-name pkg)
|
|
(db:pkg-catalog pkg)
|
|
(db:pkg-checksum pkg))])
|
|
(hash 'name (db:pkg-name pkg)
|
|
'author (db:pkg-author pkg)
|
|
'source (db:pkg-source pkg)
|
|
'checksum (db:pkg-checksum pkg)
|
|
'description (db:pkg-desc pkg)
|
|
'tags tags
|
|
'modules mods
|
|
'dependencies deps))
|
|
(hash 'source (db:pkg-source pkg)
|
|
'checksum (db:pkg-source pkg))))
|
|
|
|
(define (remote-package-checksum pkg download-printf)
|
|
(match pkg
|
|
[`(catalog ,pkg-name)
|
|
(hash-ref (package-catalog-lookup pkg-name #f) 'checksum)]
|
|
[`(url ,pkg-url-str)
|
|
(package-url->checksum pkg-url-str
|
|
#:download-printf download-printf)]))
|
|
|
|
(define (read-file-hash file)
|
|
(define the-db
|
|
(with-handlers ([exn:fail? (λ (x)
|
|
(log-exn x "reading file hash")
|
|
(hash))])
|
|
(if (file-exists? file) ; don't complain if the file is missing
|
|
(file->value file)
|
|
(hash))))
|
|
the-db)
|
|
|
|
(define (write-file-hash! file new-db)
|
|
(make-parent-directory* file)
|
|
(with-output-to-file file
|
|
#:exists 'replace
|
|
(λ () (write new-db))))
|
|
|
|
(define (read-pkg-db)
|
|
(if (current-no-pkg-db)
|
|
#hash()
|
|
(let ([the-db (read-file-hash (pkg-db-file))])
|
|
;; compatibility: map 'pnr to 'catalog:
|
|
(for/hash ([(k v) (in-hash the-db)])
|
|
(values k
|
|
(if (eq? 'pnr (car (pkg-info-orig-pkg v)))
|
|
(struct-copy pkg-info v
|
|
[orig-pkg `(catalog ,(cadr (pkg-info-orig-pkg v)))])
|
|
v))))))
|
|
|
|
(define (package-info pkg-name [fail? #t])
|
|
(define db (read-pkg-db))
|
|
(define pi (hash-ref db pkg-name #f))
|
|
(cond
|
|
[pi
|
|
pi]
|
|
[(not fail?)
|
|
#f]
|
|
[else
|
|
(pkg-not-installed pkg-name db)]))
|
|
|
|
;; return the current scope as a string
|
|
;; -> (or/c "user" "shared" "installation")
|
|
(define (current-scope->string)
|
|
(symbol->string (current-pkg-scope)))
|
|
|
|
;; prints an error for packages that are not installed
|
|
;; pkg-name db -> void
|
|
(define (pkg-not-installed pkg-name db)
|
|
(define installation-db
|
|
(parameterize ([current-pkg-scope 'installation])
|
|
(read-pkg-db)))
|
|
(define user-db
|
|
(parameterize ([current-pkg-scope 'user])
|
|
(read-pkg-db)))
|
|
(define shared-db
|
|
(parameterize ([current-pkg-scope 'shared])
|
|
(read-pkg-db)))
|
|
|
|
;; see if the package is installed in any scope
|
|
(define-values (in-install? in-user? in-shared?)
|
|
(values
|
|
(and (hash-ref installation-db pkg-name #f)
|
|
"--installation")
|
|
(and (hash-ref user-db pkg-name #f)
|
|
"--user")
|
|
(and (hash-ref shared-db pkg-name #f)
|
|
"--shared")))
|
|
|
|
(define not-installed-msg
|
|
(cond [(or in-user? in-install? in-shared?)
|
|
=>
|
|
(λ (scope-str)
|
|
(~a "could not remove package\n"
|
|
" package installed in a different scope: "
|
|
(substring scope-str 2) "\n"
|
|
" consider using the " scope-str " flag\n"))]
|
|
[else (~a "could not remove package\n"
|
|
" package not currently installed\n")]))
|
|
|
|
(pkg-error (~a not-installed-msg
|
|
" current scope: ~a\n"
|
|
" package: ~a\n"
|
|
" currently installed:~a")
|
|
(current-scope->string)
|
|
pkg-name
|
|
(format-list (hash-keys db))))
|
|
|
|
(define (update-pkg-db! pkg-name info)
|
|
(write-file-hash!
|
|
(pkg-db-file)
|
|
(hash-set (read-pkg-db) pkg-name info)))
|
|
(define (remove-from-pkg-db! pkg-name)
|
|
(write-file-hash!
|
|
(pkg-db-file)
|
|
(hash-remove (read-pkg-db) pkg-name)))
|
|
(define (read-pkg-cfg)
|
|
(read-file-hash (pkg-config-file)))
|
|
(define (update-pkg-cfg! key val)
|
|
(write-file-hash!
|
|
(pkg-config-file)
|
|
(hash-set (read-pkg-cfg) key val)))
|
|
|
|
(define (default-pkg-scope)
|
|
(match (default-pkg-scope-as-string)
|
|
["installation" 'installation]
|
|
["shared" 'shared]
|
|
[else 'user]))
|
|
(define (default-pkg-scope-as-string)
|
|
(parameterize ([current-pkg-scope 'installation])
|
|
(with-pkg-lock/read-only
|
|
(define cfg (read-pkg-cfg))
|
|
(hash-ref cfg "default-scope" "user"))))
|
|
|
|
(struct pkg-info (orig-pkg checksum auto?) #:prefab)
|
|
(struct install-info (name orig-pkg directory clean? checksum))
|
|
|
|
(define (update-install-info-orig-pkg if op)
|
|
(struct-copy install-info if
|
|
[orig-pkg op]))
|
|
(define (update-install-info-checksum if op)
|
|
(struct-copy install-info if
|
|
[checksum op]))
|
|
|
|
(define (pkg-directory pkg-name)
|
|
(for/or ([scope (in-list '(user shared installation))])
|
|
(parameterize ([current-pkg-scope scope])
|
|
(with-pkg-lock/read-only
|
|
(pkg-directory* pkg-name)))))
|
|
|
|
(define (pkg-directory* pkg-name)
|
|
(define info (package-info pkg-name #f))
|
|
(and info
|
|
(let ()
|
|
(match-define (pkg-info orig-pkg checksum _) info)
|
|
(match orig-pkg
|
|
[`(link ,orig-pkg-dir)
|
|
orig-pkg-dir]
|
|
[_
|
|
(build-path (pkg-installed-dir) pkg-name)]))))
|
|
|
|
(define (path->pkg given-p)
|
|
(define (explode p)
|
|
(explode-path
|
|
(normal-case-path
|
|
(simple-form-path p))))
|
|
(define (sub-path? < p d)
|
|
(and ((length d) . <= . (length p))
|
|
(for/and ([de (in-list d)]
|
|
[pe (in-list p)])
|
|
(equal? de pe))))
|
|
(define p (explode given-p))
|
|
(for/or ([scope (in-list '(user shared installation))])
|
|
(parameterize ([current-pkg-scope scope])
|
|
(with-pkg-lock/read-only
|
|
(define d (explode (pkg-installed-dir)))
|
|
(cond
|
|
[(sub-path? < p d)
|
|
;; Under the installation mode's package directory.
|
|
;; We assume that no one else writes there, so the
|
|
;; next path element is the package name.
|
|
(path-element->string (list-ref p (length d)))]
|
|
[else
|
|
;; Maybe it's a linked package
|
|
(for/or ([(k v) (in-hash (read-pkg-db))])
|
|
(match (pkg-info-orig-pkg v)
|
|
[`(link ,orig-pkg-dir)
|
|
(and (sub-path? <= p (explode orig-pkg-dir))
|
|
k)]
|
|
[else #f]))])))))
|
|
|
|
(define ((remove-package quiet?) pkg-name)
|
|
(unless quiet?
|
|
(printf "Removing ~a\n" pkg-name))
|
|
(match-define (pkg-info orig-pkg checksum _)
|
|
(package-info pkg-name))
|
|
(define pkg-dir (pkg-directory* pkg-name))
|
|
(remove-from-pkg-db! pkg-name)
|
|
(match orig-pkg
|
|
[`(link ,_)
|
|
(links pkg-dir
|
|
#:remove? #t
|
|
#:user? (not (eq? (current-pkg-scope) 'installation))
|
|
#:version-regexp (link-version-regexp)
|
|
#:root? #t)]
|
|
[_
|
|
(links pkg-dir
|
|
#:remove? #t
|
|
#:user? (not (eq? (current-pkg-scope) 'installation))
|
|
#:version-regexp (link-version-regexp)
|
|
#:root? #t)
|
|
(delete-directory/files pkg-dir)]))
|
|
|
|
(define (pkg-remove in-pkgs
|
|
#:force? [force? #f]
|
|
#:auto? [auto? #f]
|
|
#:quiet? [quiet? #f])
|
|
(define db (read-pkg-db))
|
|
(define all-pkgs
|
|
(hash-keys db))
|
|
(define all-pkgs-set
|
|
(list->set all-pkgs))
|
|
(define metadata-ns (make-metadata-namespace))
|
|
(define pkgs
|
|
(if auto?
|
|
(set->list
|
|
(set-subtract
|
|
(list->set
|
|
(filter
|
|
(λ (p) (pkg-info-auto? (hash-ref db p)))
|
|
all-pkgs))
|
|
(list->set
|
|
(append-map (package-dependencies metadata-ns)
|
|
all-pkgs))))
|
|
in-pkgs))
|
|
(define setup-collects
|
|
(get-setup-collects (filter-map pkg-directory* pkgs)
|
|
metadata-ns))
|
|
(unless force?
|
|
(define pkgs-set (list->set pkgs))
|
|
(define remaining-pkg-db-set
|
|
(set-subtract all-pkgs-set
|
|
pkgs-set))
|
|
(define deps-to-be-removed
|
|
(set-intersect
|
|
pkgs-set
|
|
(list->set
|
|
(append-map (package-dependencies metadata-ns)
|
|
(set->list
|
|
remaining-pkg-db-set)))))
|
|
(unless (set-empty? deps-to-be-removed)
|
|
(pkg-error (~a "cannot remove packages that are dependencies of other packages\n"
|
|
" dependencies:~a")
|
|
(format-list
|
|
(map
|
|
(λ (p)
|
|
(define ds
|
|
(filter (λ (dp)
|
|
(member p ((package-dependencies metadata-ns) dp)))
|
|
(set->list
|
|
remaining-pkg-db-set)))
|
|
(~a p " (required by: " ds ")"))
|
|
(set->list deps-to-be-removed))))))
|
|
(for-each (remove-package quiet?) pkgs)
|
|
;; setup only collections that still exist:
|
|
(and setup-collects
|
|
(for/list ([c (in-list setup-collects)]
|
|
#:when (apply collection-path
|
|
(if (path-string? c) (list c) c)
|
|
#:fail (lambda (s) #f)))
|
|
c)))
|
|
|
|
;; Downloads a package (if needed) and unpacks it (if needed) into a
|
|
;; temporary directory.
|
|
(define (stage-package/info pkg
|
|
given-type
|
|
given-pkg-name
|
|
#:given-checksum [given-checksum #f]
|
|
check-sums?
|
|
download-printf)
|
|
(define-values (inferred-pkg-name type)
|
|
(if (path? pkg)
|
|
(package-source->name+type (path->string pkg)
|
|
(or given-type
|
|
(if (directory-exists? pkg)
|
|
'dir
|
|
'file)))
|
|
(package-source->name+type pkg given-type)))
|
|
(define pkg-name (or given-pkg-name inferred-pkg-name))
|
|
(when (and type (not pkg-name))
|
|
(pkg-error (~a "could not infer package name from source\n"
|
|
" source: ~a")
|
|
pkg))
|
|
(cond
|
|
[(and (eq? type 'github)
|
|
(not (regexp-match? #rx"^github://" pkg)))
|
|
;; Add "github://github.com/"
|
|
(stage-package/info (string-append "github://github.com/" pkg) type
|
|
pkg-name
|
|
#:given-checksum given-checksum
|
|
check-sums? download-printf)]
|
|
[(or (eq? type 'file-url) (eq? type 'dir-url) (eq? type 'github))
|
|
(define pkg-url (string->url pkg))
|
|
(define scheme (url-scheme pkg-url))
|
|
|
|
(define orig-pkg `(url ,pkg))
|
|
(define checksum (or given-checksum
|
|
(remote-package-checksum orig-pkg download-printf)))
|
|
(define info
|
|
(update-install-info-orig-pkg
|
|
(match type
|
|
['github
|
|
(unless checksum
|
|
(pkg-error
|
|
(~a "could not find checksum for github package source, which implies it doesn't exist\n"
|
|
" source: ~a")
|
|
pkg))
|
|
(match-define (list* user repo branch path)
|
|
(map path/param-path (url-path/no-slash pkg-url)))
|
|
(define new-url
|
|
(url "https" #f "github.com" #f #t
|
|
(map (λ (x) (path/param x empty))
|
|
(list user repo "tarball" checksum))
|
|
empty
|
|
#f))
|
|
(define tmp.tgz
|
|
(make-temporary-file
|
|
(string-append
|
|
"~a-"
|
|
(format "~a.~a.tgz" repo branch))
|
|
#f))
|
|
(delete-file tmp.tgz)
|
|
(define tmp-dir
|
|
(make-temporary-file
|
|
(string-append
|
|
"~a-"
|
|
(format "~a.~a" repo branch))
|
|
'directory))
|
|
(define package-path
|
|
(apply build-path tmp-dir path))
|
|
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(download-printf "Downloading ~a\n" (url->string new-url))
|
|
(download-file! new-url tmp.tgz)
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(untar tmp.tgz tmp-dir #:strip-components 1)
|
|
(stage-package/info (path->string package-path)
|
|
'dir
|
|
pkg-name
|
|
#:given-checksum checksum
|
|
check-sums?
|
|
download-printf))
|
|
(λ ()
|
|
(delete-directory/files tmp-dir))))
|
|
(λ ()
|
|
(delete-directory/files tmp.tgz)))]
|
|
[_
|
|
(define url-last-component
|
|
(path/param-path (last (url-path pkg-url))))
|
|
(define url-looks-like-directory? (eq? type 'dir-url))
|
|
(define-values
|
|
(package-path download-type download-package!)
|
|
(cond
|
|
[url-looks-like-directory?
|
|
(define package-path
|
|
(make-temporary-file
|
|
(string-append
|
|
"~a-"
|
|
pkg-name)
|
|
'directory))
|
|
(define (path-like f)
|
|
(build-path package-path f))
|
|
(define (url-like f)
|
|
(if (and (pair? (url-path pkg-url))
|
|
(equal? "" (path/param-path (last (url-path pkg-url)))))
|
|
;; normal relative path:
|
|
(combine-url/relative pkg-url f)
|
|
;; we're assuming that the last path element is
|
|
;; a directory, so just add f:
|
|
(struct-copy url pkg-url [path
|
|
(append
|
|
(url-path pkg-url)
|
|
(list (path/param f null)))])))
|
|
(values package-path
|
|
'dir
|
|
(λ ()
|
|
(download-printf "\tCloning remote directory ~a\n"
|
|
(url->string pkg-url))
|
|
(make-directory* package-path)
|
|
(define manifest
|
|
(call/input-url+200
|
|
(url-like "MANIFEST")
|
|
port->lines))
|
|
(unless manifest
|
|
(pkg-error (~a "could not find MANIFEST for package source\n"
|
|
" source: ~a")
|
|
pkg))
|
|
(for ([f (in-list manifest)])
|
|
(download-file! (url-like f)
|
|
(path-like f)))))]
|
|
[else
|
|
(define package-path
|
|
(make-temporary-file
|
|
(string-append
|
|
"~a-"
|
|
url-last-component)
|
|
#f))
|
|
(delete-file package-path)
|
|
(values package-path
|
|
'file
|
|
(λ ()
|
|
(log-pkg-debug "\tAssuming URL names a file")
|
|
(download-file! pkg-url package-path)))]))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(download-package!)
|
|
(log-pkg-debug "\tDownloading done, installing ~a as ~a"
|
|
package-path pkg-name)
|
|
(stage-package/info package-path
|
|
download-type
|
|
pkg-name
|
|
#:given-checksum checksum
|
|
check-sums?
|
|
download-printf))
|
|
(λ ()
|
|
(when (or (file-exists? package-path)
|
|
(directory-exists? package-path))
|
|
(delete-directory/files package-path))))])
|
|
orig-pkg))
|
|
(when (and check-sums?
|
|
(install-info-checksum info)
|
|
(not checksum))
|
|
(pkg-error (~a "remote package had no checksum\n"
|
|
" package: ~a")
|
|
pkg))
|
|
(when (and checksum
|
|
(install-info-checksum info)
|
|
check-sums?
|
|
(not (equal? (install-info-checksum info) checksum)))
|
|
(pkg-error (~a "incorrect checksum on package\n"
|
|
" package: ~a\n"
|
|
" expected ~e\n"
|
|
" got ~e")
|
|
pkg
|
|
(install-info-checksum info) checksum))
|
|
(update-install-info-checksum
|
|
info
|
|
checksum)]
|
|
[(eq? type 'file)
|
|
(unless (file-exists? pkg)
|
|
(pkg-error "no such file\n path: ~a" pkg))
|
|
(define checksum-pth (format "~a.CHECKSUM" pkg))
|
|
(define expected-checksum
|
|
(and (file-exists? checksum-pth)
|
|
check-sums?
|
|
(file->string checksum-pth)))
|
|
(define actual-checksum
|
|
(with-input-from-file pkg
|
|
(λ ()
|
|
(sha1 (current-input-port)))))
|
|
(unless (or (not expected-checksum)
|
|
(string=? expected-checksum actual-checksum))
|
|
(pkg-error (~a "incorrect checksum on package\n"
|
|
" expected: ~e\n"
|
|
" got: ~e")
|
|
expected-checksum actual-checksum))
|
|
(define checksum
|
|
actual-checksum)
|
|
(define pkg-format (filename-extension pkg))
|
|
(define pkg-dir
|
|
(make-temporary-file (string-append "~a-" pkg-name)
|
|
'directory))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(make-directory* pkg-dir)
|
|
|
|
(match pkg-format
|
|
[#"tgz"
|
|
(untar pkg pkg-dir)]
|
|
[#"tar"
|
|
(untar pkg pkg-dir)]
|
|
[#"gz" ; assuming .tar.gz
|
|
(untar pkg pkg-dir)]
|
|
[#"zip"
|
|
(unzip pkg (make-filesystem-entry-reader #:dest pkg-dir))]
|
|
[#"plt"
|
|
(make-directory* pkg-dir)
|
|
(unpack pkg pkg-dir
|
|
(lambda (x) (log-pkg-debug "~a" x))
|
|
(lambda () pkg-dir)
|
|
#f
|
|
(lambda (auto-dir main-dir file) pkg-dir))]
|
|
[x
|
|
(pkg-error "invalid package format\n given: ~a" x)])
|
|
|
|
(update-install-info-checksum
|
|
(update-install-info-orig-pkg
|
|
(stage-package/info pkg-dir
|
|
'dir
|
|
pkg-name
|
|
#:given-checksum checksum
|
|
check-sums?
|
|
download-printf)
|
|
`(file ,(simple-form-path* pkg)))
|
|
checksum))
|
|
(λ ()
|
|
(delete-directory/files pkg-dir)))]
|
|
[(or (eq? type 'dir)
|
|
(eq? type 'link))
|
|
(unless (directory-exists? pkg)
|
|
(pkg-error "no such directory\n path: ~a" pkg))
|
|
(let ([pkg (directory-path-no-slash pkg)])
|
|
(cond
|
|
[(eq? type 'link)
|
|
(install-info pkg-name
|
|
`(link ,(simple-form-path* pkg))
|
|
pkg
|
|
#f #f)]
|
|
[else
|
|
(define pkg-dir
|
|
(make-temporary-file "pkg~a" 'directory))
|
|
(delete-directory pkg-dir)
|
|
(make-parent-directory* pkg-dir)
|
|
(copy-directory/files pkg pkg-dir)
|
|
(install-info pkg-name
|
|
`(dir ,(simple-form-path* pkg))
|
|
pkg-dir
|
|
#t #f)]))]
|
|
[(eq? type 'name)
|
|
(define catalog-info (package-catalog-lookup pkg #f))
|
|
(define source (hash-ref catalog-info 'source))
|
|
(define checksum (hash-ref catalog-info 'checksum))
|
|
(define info (stage-package/info source
|
|
#f
|
|
pkg-name
|
|
#:given-checksum checksum
|
|
check-sums?
|
|
download-printf))
|
|
(when (and (install-info-checksum info)
|
|
check-sums?
|
|
(not (equal? (install-info-checksum info) checksum)))
|
|
(pkg-error "incorrect checksum on package\n package: ~a" pkg))
|
|
(update-install-info-orig-pkg
|
|
(update-install-info-checksum
|
|
info
|
|
checksum)
|
|
`(catalog ,pkg))]
|
|
[else
|
|
(pkg-error "cannot infer package source type\n source: ~a" pkg)]))
|
|
|
|
(define (pkg-stage desc
|
|
#:checksum [checksum #f])
|
|
(define i (stage-package/info (pkg-desc-source desc)
|
|
(pkg-desc-type desc)
|
|
(pkg-desc-name desc)
|
|
#:given-checksum checksum
|
|
#t
|
|
void))
|
|
(values (install-info-directory i)
|
|
(install-info-checksum i)
|
|
(install-info-clean? i)))
|
|
|
|
(define (install-packages
|
|
#:old-infos [old-infos empty]
|
|
#:old-descs [old-descs empty]
|
|
#:pre-succeed [pre-succeed void]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:updating? [updating? #f]
|
|
#:ignore-checksums? [ignore-checksums? #f]
|
|
#:force? [force? #f]
|
|
#:quiet? [quiet? #f]
|
|
descs)
|
|
(define download-printf (if quiet? void printf))
|
|
(define check-sums? (not ignore-checksums?))
|
|
(define db (read-pkg-db))
|
|
(define db+with-dbs
|
|
(let ([with-sys-wide (lambda (t)
|
|
(parameterize ([current-pkg-scope 'installation])
|
|
(t)))]
|
|
[with-vers-spec (lambda (t)
|
|
(parameterize ([current-pkg-scope 'user])
|
|
(t)))]
|
|
[with-vers-all (lambda (t)
|
|
(parameterize ([current-pkg-scope 'shared])
|
|
(t)))]
|
|
[with-current (lambda (t) (t))])
|
|
(case (current-pkg-scope)
|
|
[(installation)
|
|
(list (cons db with-current))]
|
|
[(user)
|
|
(list (cons (with-sys-wide read-pkg-db) with-sys-wide)
|
|
(cons db with-current)
|
|
(cons (with-vers-all read-pkg-db) with-vers-all))]
|
|
[(shared)
|
|
(list (cons (with-sys-wide read-pkg-db) with-sys-wide)
|
|
(cons (with-vers-spec read-pkg-db) with-vers-spec)
|
|
(cons db with-current))]
|
|
[else (error "unknown package scope")])))
|
|
(define (install-package/outer infos desc info)
|
|
(match-define (pkg-desc pkg type orig-name auto?) desc)
|
|
(match-define
|
|
(install-info pkg-name orig-pkg pkg-dir clean? checksum)
|
|
info)
|
|
(define name? (eq? 'catalog (first orig-pkg)))
|
|
(define (clean!)
|
|
(when clean?
|
|
(delete-directory/files pkg-dir)))
|
|
(define simultaneous-installs
|
|
(for/hash ([i (in-list infos)])
|
|
(values (install-info-name i) (install-info-directory i))))
|
|
(cond
|
|
[(and (not updating?) (package-info pkg-name #f))
|
|
(clean!)
|
|
(pkg-error "package is already installed\n package: ~a" pkg-name)]
|
|
[(and
|
|
(not force?)
|
|
(for/or ([c (in-list (package-collections pkg-dir metadata-ns))]
|
|
[d (in-list (package-collection-directories pkg-dir metadata-ns))]
|
|
#:when #t
|
|
[f (in-list (directory-list* d))]
|
|
#:when (member (filename-extension f)
|
|
(list #"rkt" #"ss")))
|
|
(define (has-collection-file? other-pkg-dir)
|
|
(for/or ([other-c (in-list (package-collections other-pkg-dir metadata-ns))]
|
|
[other-d (in-list (package-collection-directories other-pkg-dir metadata-ns))])
|
|
(and (collection-equal? c other-c)
|
|
(file-exists? (build-path other-d f)))))
|
|
(or
|
|
;; Compare with main installation's collections
|
|
;; FIXME: this should check all collection paths that aren't
|
|
;; from the package system.
|
|
(and (file-exists? (build-path (find-collects-dir) c f))
|
|
(cons "racket" (build-path c f)))
|
|
;; Compare with installed packages
|
|
(for*/or ([db+with-db (in-list db+with-dbs)]
|
|
[other-pkg (in-hash-keys (car db+with-db))]
|
|
#:unless (and updating? (equal? other-pkg pkg-name)))
|
|
(and ((cdr db+with-db)
|
|
(lambda () (has-collection-file? (pkg-directory* other-pkg))))
|
|
(cons other-pkg (build-path c f))))
|
|
;; Compare with simultaneous installs
|
|
(for/or ([other-pkg-info (in-list infos)]
|
|
#:unless (eq? other-pkg-info info))
|
|
(and (has-collection-file? (install-info-directory other-pkg-info))
|
|
(cons (install-info-name other-pkg-info) (build-path c f)))))))
|
|
=>
|
|
(λ (conflicting-pkg*file)
|
|
(clean!)
|
|
(match-define (cons conflicting-pkg file) conflicting-pkg*file)
|
|
(pkg-error (~a "packages conflict\n"
|
|
" package: ~a\n"
|
|
" package: ~a\n"
|
|
" file: ~a")
|
|
pkg conflicting-pkg file))]
|
|
[(and
|
|
(not (eq? dep-behavior 'force))
|
|
(let ()
|
|
(define deps (get-metadata metadata-ns pkg-dir
|
|
'deps (lambda () empty)
|
|
#:checker check-dependencies))
|
|
(define unsatisfied-deps
|
|
(map dependency->source
|
|
(filter-not (λ (dep)
|
|
(define name (dependency->name dep))
|
|
(or (equal? name "racket")
|
|
(not (dependency-this-platform? dep))
|
|
(hash-ref simultaneous-installs name #f)
|
|
(hash-has-key? db name)))
|
|
deps)))
|
|
(and (not (empty? unsatisfied-deps))
|
|
unsatisfied-deps)))
|
|
=>
|
|
(λ (unsatisfied-deps)
|
|
(match
|
|
(or dep-behavior
|
|
(if name?
|
|
'search-ask
|
|
'fail))
|
|
['fail
|
|
(clean!)
|
|
(pkg-error (~a "missing dependencies\n"
|
|
" for package: ~a\n"
|
|
" missing packages:~a")
|
|
pkg
|
|
(format-list unsatisfied-deps))]
|
|
['search-auto
|
|
(printf (string-append
|
|
"The following packages are listed as dependencies, but are not currently installed,\n"
|
|
"so they will be automatically installed:\n"))
|
|
(printf "\t")
|
|
(for ([p (in-list unsatisfied-deps)])
|
|
(printf "~a " p))
|
|
(printf "\n")
|
|
(raise (vector updating? infos unsatisfied-deps void))]
|
|
['search-ask
|
|
(printf "The following packages are listed as dependencies, but are not currently installed:\n")
|
|
(printf "\t")
|
|
(for ([p (in-list unsatisfied-deps)])
|
|
(printf "~a " p))
|
|
(printf "\n")
|
|
(let loop ()
|
|
(printf "Would you like to install them via your package indices? [Yn] ")
|
|
(flush-output)
|
|
(match (read-line)
|
|
[(or "y" "Y" "")
|
|
(raise (vector updating? infos unsatisfied-deps void))]
|
|
[(or "n" "N")
|
|
(clean!)
|
|
(pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))]
|
|
[x
|
|
(eprintf "Invalid input: ~e\n" x)
|
|
(loop)]))]))]
|
|
[(and
|
|
(not (eq? dep-behavior 'force))
|
|
(let ()
|
|
(define deps (get-metadata metadata-ns pkg-dir
|
|
'deps (lambda () empty)
|
|
#:checker check-dependencies))
|
|
(define update-deps
|
|
(filter-map (λ (dep)
|
|
(define name (dependency->name dep))
|
|
(define req-vers (dependency->version dep))
|
|
(define this-platform? (dependency-this-platform? dep))
|
|
(define-values (inst-vers* can-try-update?)
|
|
(cond
|
|
[(not this-platform?)
|
|
(values #f #f)]
|
|
[(not req-vers)
|
|
(values #f #f)]
|
|
[(equal? name "racket")
|
|
(values (version) #f)]
|
|
[(hash-ref simultaneous-installs name #f)
|
|
=> (lambda (dir)
|
|
(values
|
|
(get-metadata metadata-ns dir
|
|
'version (lambda () "0.0"))
|
|
#f))]
|
|
[else
|
|
(values (get-metadata metadata-ns (pkg-directory* name)
|
|
'version (lambda () "0.0"))
|
|
#t)]))
|
|
(define inst-vers (if (and this-platform?
|
|
req-vers
|
|
(not (and (string? inst-vers*)
|
|
(valid-version? inst-vers*))))
|
|
(begin
|
|
(log-pkg-error
|
|
"bad verson specification for ~a: ~e"
|
|
name
|
|
inst-vers*)
|
|
"0.0")
|
|
inst-vers*))
|
|
(and this-platform?
|
|
req-vers
|
|
((version->integer req-vers)
|
|
. > .
|
|
(version->integer inst-vers))
|
|
(list name can-try-update? inst-vers req-vers)))
|
|
deps))
|
|
(and (not (empty? update-deps))
|
|
update-deps)))
|
|
=> (lambda (update-deps)
|
|
(define (report-mismatch update-deps)
|
|
(define multi? (1 . < . (length update-deps)))
|
|
(pkg-error (~a "version mismatch for dependenc~a\n"
|
|
" for package: ~a\n"
|
|
" mismatch packages:~a")
|
|
(if multi? "ies" "y")
|
|
pkg
|
|
(format-deps update-deps)))
|
|
(define (format-deps update-deps)
|
|
(format-list (for/list ([ud (in-list update-deps)])
|
|
(format "~a (have ~a, need ~a)"
|
|
(car ud)
|
|
(caddr ud)
|
|
(cadddr ud)))))
|
|
;; If there's a mismatch that we can't attempt to update, complain.
|
|
(unless (andmap cadr update-deps)
|
|
(report-mismatch (filter (compose not cadr) update-deps)))
|
|
;; Try updates:
|
|
(define update-pkgs (map car update-deps))
|
|
(define (make-pre-succeed)
|
|
(let ([to-update (filter-map (update-package download-printf) update-pkgs)])
|
|
(λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))))
|
|
(match (or dep-behavior
|
|
(if name?
|
|
'search-ask
|
|
'fail))
|
|
['fail
|
|
(clean!)
|
|
(report-mismatch update-deps)]
|
|
['search-auto
|
|
(printf (string-append
|
|
"The following packages are listed as dependencies, but are not at the required\n"
|
|
"version, so they will be automatically updated:~a\n")
|
|
(format-deps update-deps))
|
|
(raise (vector #t infos update-pkgs (make-pre-succeed)))]
|
|
['search-ask
|
|
(printf (~a "The following packages are listed as dependencies, but are not at the required\n"
|
|
"versions:~a\n")
|
|
(format-deps update-deps))
|
|
(let loop ()
|
|
(printf "Would you like to update them via your package indices? [Yn] ")
|
|
(flush-output)
|
|
(match (read-line)
|
|
[(or "y" "Y" "")
|
|
(raise (vector #t infos update-pkgs (make-pre-succeed)))]
|
|
[(or "n" "N")
|
|
(clean!)
|
|
(report-mismatch update-deps)]
|
|
[x
|
|
(eprintf "Invalid input: ~e\n" x)
|
|
(loop)]))]))]
|
|
[else
|
|
(λ ()
|
|
(define final-pkg-dir
|
|
(cond
|
|
[clean?
|
|
(define final-pkg-dir (build-path (pkg-installed-dir) pkg-name))
|
|
(make-parent-directory* final-pkg-dir)
|
|
(copy-directory/files pkg-dir final-pkg-dir)
|
|
(clean!)
|
|
final-pkg-dir]
|
|
[else
|
|
pkg-dir]))
|
|
(log-pkg-debug "creating link to ~e" final-pkg-dir)
|
|
(links final-pkg-dir
|
|
#:user? (not (eq? 'installation (current-pkg-scope)))
|
|
#:version-regexp (link-version-regexp)
|
|
#:root? #t)
|
|
(define this-pkg-info
|
|
(pkg-info orig-pkg checksum auto?))
|
|
(log-pkg-debug "updating db with ~e to ~e" pkg-name this-pkg-info)
|
|
(update-pkg-db! pkg-name this-pkg-info))]))
|
|
(define metadata-ns (make-metadata-namespace))
|
|
(define infos
|
|
(for/list ([v (in-list descs)])
|
|
(stage-package/info (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v)
|
|
check-sums? download-printf)))
|
|
(define setup-collects (get-setup-collects (map install-info-directory
|
|
(append old-infos infos))
|
|
metadata-ns))
|
|
(define do-its
|
|
(map (curry install-package/outer (append old-infos infos))
|
|
(append old-descs descs)
|
|
(append old-infos infos)))
|
|
(pre-succeed)
|
|
(for-each (λ (t) (t)) do-its)
|
|
setup-collects)
|
|
|
|
(define (get-setup-collects pkg-directories metadata-ns)
|
|
(maybe-append
|
|
(for/list ([pkg-dir (in-list pkg-directories)])
|
|
(get-metadata metadata-ns pkg-dir
|
|
'setup-collects (lambda () (package-collections
|
|
pkg-dir
|
|
metadata-ns))
|
|
#:checker (lambda (v)
|
|
(unless (or (eq? v 'all)
|
|
(and (list? v)
|
|
(for ([c (in-list v)])
|
|
(or (path-string? c)
|
|
(and (list? c)
|
|
(pair? c)
|
|
(andmap path-string? c))))))
|
|
(pkg-error "bad 'setup-collects value\n value: ~e"
|
|
v)))))))
|
|
|
|
(define (pkg-install descs
|
|
#:old-infos [old-infos empty]
|
|
#:old-auto+pkgs [old-descs empty]
|
|
#:force? [force #f]
|
|
#:ignore-checksums? [ignore-checksums #f]
|
|
#:pre-succeed [pre-succeed void]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:updating? [updating? #f]
|
|
#:quiet? [quiet? #f])
|
|
(with-handlers* ([vector?
|
|
(match-lambda
|
|
[(vector updating? new-infos deps more-pre-succeed)
|
|
(pkg-install
|
|
#:old-infos new-infos
|
|
#:old-auto+pkgs (append old-descs descs)
|
|
#:force? force
|
|
#:ignore-checksums? ignore-checksums
|
|
#:dep-behavior dep-behavior
|
|
#:pre-succeed (lambda () (pre-succeed) (more-pre-succeed))
|
|
#:updating? updating?
|
|
(for/list ([dep (in-list deps)])
|
|
(pkg-desc dep #f #f #t)))])])
|
|
(install-packages
|
|
#:old-infos old-infos
|
|
#:old-descs old-descs
|
|
#:force? force
|
|
#:ignore-checksums? ignore-checksums
|
|
#:dep-behavior dep-behavior
|
|
#:pre-succeed pre-succeed
|
|
#:updating? updating?
|
|
#:quiet? quiet?
|
|
descs)))
|
|
|
|
(define (update-is-possible? pkg-name)
|
|
(match-define (pkg-info orig-pkg checksum _)
|
|
(package-info pkg-name))
|
|
(define ty (first orig-pkg))
|
|
(not (member ty '(link dir file))))
|
|
|
|
(define ((update-package download-printf) pkg-name)
|
|
(match-define (pkg-info orig-pkg checksum auto?)
|
|
(package-info pkg-name))
|
|
(match orig-pkg
|
|
[`(link ,_)
|
|
(pkg-error (~a "cannot update linked packages\n"
|
|
" package name: ~a\n"
|
|
" package source: ~a")
|
|
pkg-name
|
|
orig-pkg)]
|
|
[`(dir ,_)
|
|
(pkg-error (~a "cannot update packages installed locally;\n"
|
|
" package was installed via a local directory\n"
|
|
" package name: ~a")
|
|
pkg-name)]
|
|
[`(file ,_)
|
|
(pkg-error (~a "cannot update packages installed locally;\n"
|
|
" package was installed via a local file\n"
|
|
" package name: ~a")
|
|
pkg-name)]
|
|
[`(,_ ,orig-pkg-source)
|
|
(define new-checksum
|
|
(remote-package-checksum orig-pkg download-printf))
|
|
(and new-checksum
|
|
(not (equal? checksum new-checksum))
|
|
;; FIXME: the type shouldn't be #f here; it should be
|
|
;; preseved from install time:
|
|
(pkg-desc orig-pkg-source #f pkg-name auto?))]))
|
|
|
|
(define ((package-dependencies metadata-ns) pkg-name)
|
|
(get-metadata metadata-ns (pkg-directory* pkg-name)
|
|
'deps (lambda () empty)
|
|
#:checker check-dependencies))
|
|
|
|
(define (pkg-update in-pkgs
|
|
#:all? [all? #f]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:deps? [deps? #f]
|
|
#:quiet? [quiet? #f])
|
|
(define download-printf (if quiet? void printf))
|
|
(define metadata-ns (make-metadata-namespace))
|
|
(define pkgs
|
|
(cond
|
|
[(and all? (empty? in-pkgs))
|
|
(filter update-is-possible? (hash-keys (read-pkg-db)))]
|
|
[deps?
|
|
(append-map
|
|
(package-dependencies metadata-ns)
|
|
in-pkgs)]
|
|
[else
|
|
in-pkgs]))
|
|
(define to-update (filter-map (update-package download-printf) pkgs))
|
|
(cond
|
|
[(empty? to-update)
|
|
(printf "No updates available\n")
|
|
#f]
|
|
[else
|
|
(printf "Updating: ~a\n" to-update)
|
|
(pkg-install
|
|
#:updating? #t
|
|
#:pre-succeed (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))
|
|
#:dep-behavior dep-behavior
|
|
#:quiet? quiet?
|
|
to-update)]))
|
|
|
|
(define (pkg-show indent #:directory? [dir? #f])
|
|
(let ()
|
|
(define db (read-pkg-db))
|
|
(define pkgs (sort (hash-keys db) string-ci<=?))
|
|
(if (null? pkgs)
|
|
(printf " [none]\n")
|
|
(table-display
|
|
(list*
|
|
(list* (format "~aPackage[*=auto]" indent) "Checksum" "Source"
|
|
(if dir?
|
|
(list "Directory")
|
|
empty))
|
|
(for/list ([pkg (in-list pkgs)])
|
|
(match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg))
|
|
(list* (format "~a~a~a"
|
|
indent
|
|
pkg
|
|
(if auto?
|
|
"*"
|
|
""))
|
|
(format "~a" checksum)
|
|
(format "~a" orig-pkg)
|
|
(if dir?
|
|
(list (~a (pkg-directory* pkg)))
|
|
empty))))))))
|
|
|
|
(define (installed-pkg-table #:scope [given-scope #f])
|
|
(parameterize ([current-pkg-scope
|
|
(or given-scope (default-pkg-scope))])
|
|
(with-pkg-lock/read-only
|
|
(read-pkg-db))))
|
|
|
|
(define (installed-pkg-names #:scope [given-scope #f])
|
|
(sort (hash-keys (installed-pkg-table #:scope given-scope))
|
|
string-ci<=?))
|
|
|
|
(define (pkg-config config:set key+vals)
|
|
(cond
|
|
[config:set
|
|
(match key+vals
|
|
[(list* (and key "catalogs") val)
|
|
(update-pkg-cfg! "catalogs" val)]
|
|
[(list (and key "default-scope") val)
|
|
(unless (member val '("installation" "user" "shared"))
|
|
(pkg-error (~a "invliad value for config key\n"
|
|
" config key: ~a\n"
|
|
" given value: ~a\n"
|
|
" valid values: installation, user, or shared")
|
|
key
|
|
val))
|
|
(if (eq? 'installation (current-pkg-scope))
|
|
(update-pkg-cfg! "default-scope" val)
|
|
(pkg-error (~a "config key makes sense only with --installation/-i\n"
|
|
" config key: ~a\n"
|
|
" given value: ~a")
|
|
key
|
|
val))]
|
|
[(list key)
|
|
(pkg-error "unsupported config key\n key: ~e" key)]
|
|
[(list)
|
|
(pkg-error "config key not provided")])]
|
|
[else
|
|
(match key+vals
|
|
[(list key)
|
|
(match key
|
|
["catalogs"
|
|
(for ([s (in-list (read-pkg-cfg/def "catalogs"))])
|
|
(printf "~a\n" s))]
|
|
["default-scope"
|
|
(if (eq? 'installation (current-pkg-scope))
|
|
(printf "~a\n" (default-pkg-scope-as-string))
|
|
(pkg-error (~a "config key makes sense only with --installation/-i\n"
|
|
" config key: ~a")
|
|
key))]
|
|
[_
|
|
(pkg-error "unsupported config key\n key: ~e" key)])]
|
|
[(list)
|
|
(pkg-error "config key not provided")]
|
|
[_
|
|
(pkg-error "multiple config keys provided")])]))
|
|
|
|
(define (pkg-create create:format maybe-dir
|
|
#:quiet? [quiet? #f])
|
|
(begin
|
|
(define dir (regexp-replace* #rx"/$" maybe-dir ""))
|
|
(unless (directory-exists? dir)
|
|
(pkg-error "directory does not exist\n path: ~a" dir))
|
|
(match create:format
|
|
['MANIFEST
|
|
(unless quiet?
|
|
(printf "creating manifest for ~a\n"
|
|
dir))
|
|
(with-output-to-file
|
|
(build-path dir "MANIFEST")
|
|
#:exists 'replace
|
|
(λ ()
|
|
(for ([f (in-list (parameterize ([current-directory dir])
|
|
(find-files file-exists?)))])
|
|
(display f)
|
|
(newline))))]
|
|
[else
|
|
(define pkg (format "~a.~a" dir create:format))
|
|
(unless quiet?
|
|
(printf "packing ~a into ~a\n"
|
|
dir pkg))
|
|
(define pkg-name
|
|
(regexp-replace
|
|
(regexp (format "~a$" (regexp-quote (format ".~a" create:format))))
|
|
(path->string (file-name-from-path pkg))
|
|
""))
|
|
(match create:format
|
|
['tgz
|
|
(define pkg/complete (path->complete-path pkg))
|
|
(when (file-exists? pkg/complete)
|
|
(delete-file pkg/complete))
|
|
(parameterize ([current-directory dir])
|
|
(with-handlers ([exn? (lambda (exn)
|
|
(when (file-exists? pkg/complete)
|
|
(delete-file pkg/complete))
|
|
(raise exn))])
|
|
(apply tar-gzip pkg/complete (directory-list))))]
|
|
['zip
|
|
(define pkg/complete (path->complete-path pkg))
|
|
(when (file-exists? pkg/complete)
|
|
(delete-file pkg/complete))
|
|
(parameterize ([current-directory dir])
|
|
(with-handlers ([exn? (lambda (exn)
|
|
(when (file-exists? pkg/complete)
|
|
(delete-file pkg/complete))
|
|
(raise exn))])
|
|
(apply zip pkg/complete (directory-list))))]
|
|
['plt
|
|
(define dest (path->complete-path pkg))
|
|
(parameterize ([current-directory dir])
|
|
(define names (filter std-filter (directory-list)))
|
|
(define dirs (filter directory-exists? names))
|
|
(pack-plt dest pkg-name
|
|
names
|
|
#:plt-relative? #t
|
|
#:as-paths (map (lambda (v) (build-path "collects" v)) names)
|
|
#:collections (map list (map path->string dirs))))]
|
|
[x
|
|
(pkg-error "invalid package format\n format: ~a" x)])
|
|
(define chk (format "~a.CHECKSUM" pkg))
|
|
(unless quiet?
|
|
(printf "writing package checksum to ~a\n"
|
|
chk))
|
|
(with-output-to-file chk
|
|
#:exists 'replace
|
|
(λ () (display (call-with-input-file pkg sha1))))])))
|
|
|
|
(define (pkg-catalog-copy srcs dest
|
|
#:from-config? [from-config? #f]
|
|
#:merge? [merge? #f]
|
|
#:force? [force? #f]
|
|
#:override? [override? #f])
|
|
(define src-paths
|
|
(for/list ([src (in-list (append srcs
|
|
(if from-config?
|
|
(pkg-config-catalogs)
|
|
null)))])
|
|
(define src-path
|
|
(cond
|
|
[(path? src) (path->complete-path src)]
|
|
[(regexp-match? #rx"^https?://" src)
|
|
(string->url src)]
|
|
[(regexp-match? #rx"^file://" src)
|
|
(url->path (string->url src))]
|
|
[(regexp-match? #rx"^[a-zA-Z]*://" src)
|
|
(pkg-error (~a "unrecognized URL scheme for an catalog\n"
|
|
" URL: ~a")
|
|
src)]
|
|
[else (path->complete-path src)]))
|
|
(when (path? src-path)
|
|
(cond
|
|
[(db-path? src-path)
|
|
(void)]
|
|
[(directory-exists? src-path)
|
|
(void)]
|
|
[(let-values ([(base name dir?) (split-path src-path)]) dir?)
|
|
(void)]
|
|
[else
|
|
(pkg-error (~a "bad source catalog path\n"
|
|
" path: ~a\n"
|
|
" expected: directory or path with \".sqlite\" extension")
|
|
src)]))
|
|
src-path))
|
|
(define dest-path
|
|
(cond
|
|
[(path? dest) (path->complete-path dest)]
|
|
[(regexp-match? #rx"^file://" dest)
|
|
(url->path (string->url dest))]
|
|
[(regexp-match? #rx"^[a-zA-Z]*://" dest)
|
|
(pkg-error (~a "cannot copy to a non-file destination catalog\n"
|
|
" given URL: ~a")
|
|
dest)]
|
|
[else (path->complete-path dest)]))
|
|
|
|
(unless (or force? merge?)
|
|
(when (or (file-exists? dest-path)
|
|
(directory-exists? dest-path)
|
|
(link-exists? dest-path))
|
|
(pkg-error (~a "destination exists\n"
|
|
" path: ~a")
|
|
dest-path)))
|
|
|
|
(define details
|
|
(let ([src-paths (if (and merge?
|
|
(or (file-exists? dest-path)
|
|
(directory-exists? dest-path)))
|
|
(if override?
|
|
(append src-paths
|
|
(list dest-path))
|
|
(cons dest-path
|
|
src-paths))
|
|
src-paths)])
|
|
(parameterize ([current-pkg-catalogs (for/list ([src-path src-paths])
|
|
(if (path? src-path)
|
|
(path->url src-path)
|
|
src-path))])
|
|
(get-all-pkg-details-from-catalogs))))
|
|
|
|
(when (and force? (not merge?))
|
|
(cond
|
|
[(file-exists? dest-path)
|
|
(delete-file dest-path)]
|
|
[(directory-exists? dest-path)
|
|
(if (db-path? dest-path)
|
|
(delete-directory/files dest-path)
|
|
(for ([i (directory-list dest-path)])
|
|
(delete-directory/files (build-path dest-path i))))]
|
|
[(link-exists? dest-path)
|
|
(delete-file dest-path)]))
|
|
|
|
(cond
|
|
[(db-path? dest-path)
|
|
(parameterize ([db:current-pkg-catalog-file dest-path])
|
|
(db:set-catalogs! '("local"))
|
|
(db:set-pkgs! "local"
|
|
(for/list ([(k v) (in-hash details)])
|
|
(db:pkg k "local"
|
|
(hash-ref v 'author "")
|
|
(hash-ref v 'source "")
|
|
(hash-ref v 'checksum "")
|
|
(hash-ref v 'description ""))))
|
|
(for ([(k v) (in-hash details)])
|
|
(define t (hash-ref v 'tags '()))
|
|
(unless (null? t)
|
|
(db:set-pkg-tags! k "local" t)))
|
|
(for ([(k v) (in-hash details)])
|
|
(define mods (hash-ref v 'modules '()))
|
|
(unless (null? mods)
|
|
(define cs (hash-ref v 'checksum ""))
|
|
(db:set-pkg-modules! k "local" cs mods)))
|
|
(for ([(k v) (in-hash details)])
|
|
(define deps (hash-ref v 'dependencies '()))
|
|
(unless (null? deps)
|
|
(define cs (hash-ref v 'checksum ""))
|
|
(db:set-pkg-dependencies! k "local" cs deps))))]
|
|
[else
|
|
(define pkg-path (build-path dest-path "pkg"))
|
|
(make-directory* pkg-path)
|
|
(for ([(k v) (in-hash details)])
|
|
(call-with-output-file*
|
|
#:exists 'truncate/replace
|
|
(build-path pkg-path k)
|
|
(lambda (o) (write v o))))
|
|
(call-with-output-file*
|
|
#:exists 'truncate/replace
|
|
(build-path dest-path "pkgs")
|
|
(lambda (o) (write (hash-keys details) o)))
|
|
(call-with-output-file*
|
|
#:exists 'truncate/replace
|
|
(build-path dest-path "pkgs-all")
|
|
(lambda (o) (write details o)))]))
|
|
|
|
(define (pkg-catalog-show names
|
|
#:all? [all? #f]
|
|
#:only-names? [only-names? #f]
|
|
#:modules? [modules? #f])
|
|
(for ([name (in-list names)])
|
|
(define-values (parsed-name type)
|
|
(package-source->name+type name #f))
|
|
(unless (eq? type 'name)
|
|
(pkg-error (~a "incorrect syntax for a package name\n"
|
|
" given: ~a")
|
|
name)))
|
|
|
|
(cond
|
|
[only-names?
|
|
(define all-names (if all?
|
|
(get-all-pkg-names-from-catalogs)
|
|
names))
|
|
(for ([name (in-list all-names)])
|
|
(unless all?
|
|
;; Make sure it's available:
|
|
(get-pkg-details-from-catalogs name))
|
|
(printf "~a\n" name))]
|
|
[else
|
|
(define all-details (and all?
|
|
(get-all-pkg-details-from-catalogs)))
|
|
(for ([name (in-list (if all?
|
|
(hash-keys all-details)
|
|
names))])
|
|
(define details (if all?
|
|
(hash-ref all-details name)
|
|
(get-pkg-details-from-catalogs name)))
|
|
(printf "Package name: ~a\n" name)
|
|
(for ([key '(author source checksum tags description)])
|
|
(define v (hash-ref details key #f))
|
|
(when v
|
|
(printf " ~a: ~a\n"
|
|
(string-titlecase (symbol->string key))
|
|
(if (list? v)
|
|
(apply ~a #:separator ", " v)
|
|
v))))
|
|
(for ([key '(dependencies)])
|
|
(define v (hash-ref details key null))
|
|
(unless (null? v)
|
|
(printf " Dependencies:\n")
|
|
(for ([dep (in-list v)])
|
|
(define vers (dependency->version dep))
|
|
(define plat (dependency-lookup '#:platform dep))
|
|
(printf " ~a~a~a\n"
|
|
(dependency->name dep)
|
|
(if vers
|
|
(format " version ~a" vers)
|
|
"")
|
|
(if plat
|
|
(format " on platform ~v" plat)
|
|
"")))))
|
|
(when modules?
|
|
(printf "Modules:")
|
|
(for/fold ([col 72]) ([mod (in-list (hash-ref details 'modules null))])
|
|
(define pretty-mod (if (and (list? mod)
|
|
(= 2 (length mod))
|
|
(eq? (car mod) 'lib)
|
|
(regexp-match #rx"[.]rkt$" (cadr mod)))
|
|
(string->symbol (regexp-replace #rx"[.]rkt$" (cadr mod) ""))
|
|
mod))
|
|
(define mod-str (~a " " pretty-mod))
|
|
(define new-col (if ((+ col (string-length mod-str)) . > . 72)
|
|
(begin
|
|
(newline)
|
|
0)
|
|
col))
|
|
(display mod-str)
|
|
(+ new-col (string-length mod-str)))
|
|
(newline)))]))
|
|
|
|
(define (get-all-pkg-names-from-catalogs)
|
|
(define ht
|
|
(for*/hash ([i (in-list (pkg-catalogs))]
|
|
[name
|
|
(catalog-dispatch
|
|
i
|
|
;; Server:
|
|
(lambda (i)
|
|
(read-from-server
|
|
'get-all-pkg-names-from-catalogs
|
|
(add-version-query
|
|
(combine-url/relative i "pkgs"))
|
|
(lambda (l) (and (list? l)
|
|
(andmap string? l)))))
|
|
;; Local database:
|
|
(lambda ()
|
|
(map db:pkg-name (db:get-pkgs)))
|
|
;; Local directory:
|
|
(lambda (path)
|
|
(define pkgs-path (build-path path "pkgs"))
|
|
(cond
|
|
[(file-exists? pkgs-path)
|
|
(call-with-input-file* pkgs-path read)]
|
|
[else
|
|
(define pkg-path (build-path path "pkg"))
|
|
(for/list ([i (directory-list pkg-path)]
|
|
#:when (file-exists? (build-path pkg-path i)))
|
|
(path-element->string i))])))])
|
|
(values name #t)))
|
|
(sort (hash-keys ht) string<?))
|
|
|
|
(define (get-pkg-details-from-catalogs name)
|
|
(for/or ([i (in-list (pkg-catalogs))])
|
|
(package-catalog-lookup name #t)))
|
|
|
|
(define (get-all-pkg-details-from-catalogs)
|
|
(for/fold ([ht (hash)]) ([i (in-list (pkg-catalogs))])
|
|
(define one-ht
|
|
(catalog-dispatch
|
|
i
|
|
;; Server:
|
|
(lambda (i)
|
|
(read-from-server
|
|
'get-all-pkg-details-from-catalogs
|
|
(add-version-query
|
|
(combine-url/relative i "pkgs-all"))
|
|
(lambda (v)
|
|
(and (hash? v)
|
|
(for/and ([(k v) (in-hash v)])
|
|
(and (string? k)
|
|
(hash? v)
|
|
(for/and ([k (in-hash-keys v)])
|
|
(symbol? k))))))))
|
|
;; Local database:
|
|
(lambda ()
|
|
(define pkgs (db:get-pkgs))
|
|
(for/fold ([ht (hash)]) ([p (in-list pkgs)])
|
|
(if (hash-ref ht (db:pkg-name p) #f)
|
|
ht
|
|
(hash-set ht
|
|
(db:pkg-name p)
|
|
(db-pkg-info p #t)))))
|
|
;; Local directory:
|
|
(lambda (path)
|
|
(define pkgs-all-path (build-path path "pkgs-all"))
|
|
(cond
|
|
[(file-exists? pkgs-all-path)
|
|
(call-with-input-file* pkgs-all-path read)]
|
|
[else
|
|
(define pkg-path (build-path path "pkg"))
|
|
(for/hash ([i (directory-list pkg-path)]
|
|
#:when (file-exists? (build-path pkg-path i)))
|
|
(values (path-element->string i)
|
|
(call-with-input-file* (build-path pkg-path i)
|
|
read)))]))))
|
|
(for/fold ([ht ht]) ([(k v) (in-hash one-ht)])
|
|
(if (hash-ref ht k #f)
|
|
ht
|
|
(hash-set ht k v)))))
|
|
|
|
(define (extract-dependencies get-info)
|
|
(define v (if get-info
|
|
(get-info 'deps (lambda () empty))
|
|
empty))
|
|
(check-dependencies v)
|
|
v)
|
|
|
|
(define (get-pkg-content desc
|
|
#:extract-info [extract-info extract-dependencies])
|
|
(define-values (dir cksum clean?) (pkg-stage desc))
|
|
(define get-info (with-handlers ([exn:fail? (λ (x)
|
|
(log-exn x "getting info")
|
|
#f)])
|
|
(get-info/full dir #:namespace (make-base-namespace))))
|
|
(define module-paths
|
|
(let ([dummy (build-path (current-directory) "dummy.rkt")])
|
|
(parameterize ([current-directory dir])
|
|
(for/list ([f (in-directory)]
|
|
#:when (file-exists? f)
|
|
#:when (regexp-match? #rx#"[.](rkt|ss)$" (path->bytes f))
|
|
#:when (let-values ([(base name dir?) (split-path f)])
|
|
(not (eq? 'relative base)))
|
|
[m (in-value
|
|
(apply ~a
|
|
#:separator "/"
|
|
(map path-element->string
|
|
(explode-path f))))]
|
|
#:when (module-path? `(lib ,m)))
|
|
;; normalize the path:
|
|
(collapse-module-path `(lib ,m) dummy)))))
|
|
|
|
(begin0
|
|
(values cksum
|
|
module-paths
|
|
(extract-info get-info))
|
|
(when clean?
|
|
(delete-directory/files dir))))
|
|
|
|
|
|
(define (pkg-catalog-update-local #:catalog-file [catalog-file (db:current-pkg-catalog-file)]
|
|
#:quiet? [quiet? #f]
|
|
#:consult-packages? [consult-packages? #f])
|
|
(parameterize ([db:current-pkg-catalog-file catalog-file])
|
|
(define catalogs (pkg-config-catalogs))
|
|
(db:set-catalogs! catalogs)
|
|
|
|
(for ([catalog (in-list catalogs)])
|
|
(parameterize ([current-pkg-catalogs (list (string->url catalog))])
|
|
(define details (get-all-pkg-details-from-catalogs))
|
|
;; set packages:
|
|
(db:set-pkgs! catalog (for/list ([(name ht) (in-hash details)])
|
|
(db:pkg name
|
|
catalog
|
|
(hash-ref ht 'author "")
|
|
(hash-ref ht 'source "")
|
|
(hash-ref ht 'checksum "")
|
|
(hash-ref ht 'description ""))))
|
|
;; Add available module and dependency info:
|
|
(for/list ([(name ht) (in-hash details)])
|
|
(define checksum (hash-ref ht 'checksum ""))
|
|
(define mods (hash-ref ht 'modules #f))
|
|
(when mods
|
|
(db:set-pkg-modules! name catalog checksum mods))
|
|
(define deps (hash-ref ht 'dependencies #f))
|
|
(when deps
|
|
(db:set-pkg-dependencies! name catalog checksum deps)))
|
|
(when consult-packages?
|
|
;; If module information isn't available for a package, download
|
|
;; the package to fill in that information:
|
|
(define need-modules (db:get-pkgs-without-modules #:catalog catalog))
|
|
(for ([(pkg) (in-list need-modules)])
|
|
(define name (db:pkg-name pkg))
|
|
(define ht (hash-ref details name))
|
|
(define source (hash-ref ht 'source))
|
|
(unless quiet?
|
|
(printf "Downloading ~s\n" source))
|
|
(define-values (checksum modules deps)
|
|
(get-pkg-content (pkg-desc source
|
|
#f
|
|
(hash-ref ht 'checksum #f)
|
|
#f)))
|
|
(db:set-pkg-modules! name catalog checksum modules)
|
|
(db:set-pkg-dependencies! name catalog checksum deps)))))))
|
|
|
|
(define (choose-catalog-file)
|
|
(define default (db:current-pkg-catalog-file))
|
|
(if (file-exists? default)
|
|
default
|
|
(let ([installation (build-path (find-lib-dir) "pkgs" (file-name-from-path default))])
|
|
(if (file-exists? installation)
|
|
installation
|
|
default))))
|
|
|
|
(define (pkg-catalog-suggestions-for-module module-path
|
|
#:catalog-file [catalog-file (choose-catalog-file)])
|
|
(if (file-exists? catalog-file)
|
|
(parameterize ([db:current-pkg-catalog-file catalog-file])
|
|
(let* ([mod (collapse-module-path
|
|
module-path
|
|
(lambda () (build-path (current-directory) "dummy.rkt")))]
|
|
[pkgs (db:get-module-pkgs mod)]
|
|
[more-pkgs (let ([rx:reader #rx"/lang/reader[.]rkt$"])
|
|
(if (and (pair? mod)
|
|
(eq? (car mod) 'lib)
|
|
(regexp-match rx:reader (cadr mod)))
|
|
(db:get-module-pkgs `(lib ,(regexp-replace rx:reader (cadr mod) "/main.rkt")))
|
|
null))])
|
|
(sort (set->list
|
|
(list->set
|
|
(map db:pkg-name (append pkgs more-pkgs))))
|
|
string<?)))
|
|
null))
|
|
|
|
(define dep-behavior/c
|
|
(or/c #f 'fail 'force 'search-ask 'search-auto))
|
|
|
|
(define package-scope/c
|
|
(or/c 'installation 'user 'shared))
|
|
|
|
(provide
|
|
with-pkg-lock
|
|
with-pkg-lock/read-only
|
|
(struct-out pkg-info)
|
|
pkg-desc?
|
|
(contract-out
|
|
[current-pkg-scope
|
|
(parameter/c package-scope/c)]
|
|
[current-pkg-scope-version
|
|
(parameter/c string?)]
|
|
[current-pkg-error
|
|
(parameter/c procedure?)]
|
|
[current-pkg-catalogs
|
|
(parameter/c (or/c #f (listof url?)))]
|
|
[pkg-directory
|
|
(-> string? path-string?)]
|
|
[path->pkg
|
|
(-> path-string? (or/c #f string?))]
|
|
[pkg-desc
|
|
(-> string?
|
|
(or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)
|
|
(or/c string? #f)
|
|
boolean?
|
|
pkg-desc?)]
|
|
[pkg-config
|
|
(-> boolean? list?
|
|
void?)]
|
|
[pkg-create
|
|
(->* ((or/c 'zip 'tgz 'plt 'MANIFEST)
|
|
path-string?)
|
|
(#:quiet? boolean?)
|
|
void?)]
|
|
[pkg-update
|
|
(->* ((listof string?))
|
|
(#:dep-behavior dep-behavior/c
|
|
#:all? boolean?
|
|
#:deps? boolean?
|
|
#:quiet? boolean?)
|
|
(or/c #f (listof (or/c path-string? (non-empty-listof path-string?)))))]
|
|
[pkg-remove
|
|
(->* ((listof string?))
|
|
(#:auto? boolean?
|
|
#:force? boolean?
|
|
#:quiet? boolean?)
|
|
(or/c #f (listof (or/c path-string? (non-empty-listof path-string?)))))]
|
|
[pkg-show
|
|
(->* (string?)
|
|
(#:directory? boolean?)
|
|
void?)]
|
|
[pkg-install
|
|
(->* ((listof pkg-desc?))
|
|
(#:dep-behavior dep-behavior/c
|
|
#:force? boolean?
|
|
#:ignore-checksums? boolean?
|
|
#:quiet? boolean?)
|
|
(or/c #f (listof (or/c path-string? (non-empty-listof path-string?)))))]
|
|
[pkg-catalog-show
|
|
(->* ((listof string?))
|
|
(#:all? boolean?
|
|
#:only-names? boolean?
|
|
#:modules? boolean?)
|
|
void?)]
|
|
[pkg-catalog-copy
|
|
(->* ((listof path-string?) path-string?)
|
|
(#:from-config? any/c
|
|
#:merge? boolean?
|
|
#:force? boolean?
|
|
#:override? boolean?)
|
|
void?)]
|
|
[default-pkg-scope
|
|
(-> package-scope/c)]
|
|
[installed-pkg-names
|
|
(->* ()
|
|
(#:scope (or/c #f package-scope/c))
|
|
(listof string?))]
|
|
[installed-pkg-table
|
|
(->* ()
|
|
(#:scope (or/c #f package-scope/c))
|
|
(hash/c string? pkg-info?))]
|
|
[pkg-stage (->* (pkg-desc?)
|
|
(#:checksum (or/c #f string?))
|
|
(values path?
|
|
(or/c #f string?)
|
|
boolean?))]
|
|
[pkg-config-catalogs
|
|
(-> (listof string?))]
|
|
[pkg-catalog-update-local
|
|
(->* ()
|
|
(#:catalog-file path-string?
|
|
#:quiet? boolean?
|
|
#:consult-packages? boolean?)
|
|
void?)]
|
|
[pkg-catalog-suggestions-for-module
|
|
(->* (module-path?)
|
|
(#:catalog-file path-string?)
|
|
(listof string?))]
|
|
[get-all-pkg-names-from-catalogs
|
|
(-> (listof string?))]
|
|
[get-all-pkg-details-from-catalogs
|
|
(-> (hash/c string? (hash/c symbol? any/c)))]
|
|
[get-pkg-details-from-catalogs
|
|
(-> string?
|
|
(or/c #f (hash/c symbol? any/c)))]
|
|
[get-pkg-content
|
|
(->* (pkg-desc?)
|
|
(#:extract-info (-> (or/c #f
|
|
((symbol?) ((-> any)) . ->* . any))
|
|
any/c))
|
|
(values (or/c #f string?)
|
|
(listof module-path?)
|
|
any/c))]))
|