825 lines
28 KiB
Racket
825 lines
28 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
|
|
unstable/debug
|
|
racket/string
|
|
file/untgz
|
|
file/tar
|
|
file/zip
|
|
file/unzip
|
|
"util.rkt"
|
|
"util-plt.rkt")
|
|
|
|
(define current-install-system-wide?
|
|
(make-parameter #f))
|
|
|
|
(define (file->value* pth def)
|
|
(with-handlers ([exn:fail? (λ (x) def)])
|
|
(file->value pth)))
|
|
|
|
(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 (absolute-collects-dir)
|
|
(path->complete-path
|
|
(find-system-path 'collects-dir)
|
|
(path-only (find-executable-path (find-system-path 'exec-file)))))
|
|
|
|
(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)
|
|
(dprintf "\t\tDownloading ~a to ~a\n" (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 (if (current-install-system-wide?)
|
|
(find-lib-dir)
|
|
(find-system-path 'addon-dir))
|
|
"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)))
|
|
|
|
(for-each make-directory*
|
|
(list (pkg-dir) (pkg-installed-dir)))
|
|
|
|
(define (with-package-lock* t)
|
|
(make-directory* (pkg-dir))
|
|
(call-with-file-lock/timeout
|
|
#f 'exclusive
|
|
t
|
|
(λ () (error 'planet2 "Could not acquire package lock: ~e"
|
|
(pkg-lock-file)))
|
|
#:lock-file (pkg-lock-file)))
|
|
(define-syntax-rule (with-package-lock e ...)
|
|
(with-package-lock* (λ () e ...)))
|
|
|
|
(define (read-pkg-cfg/def k)
|
|
(define c (read-pkg-cfg))
|
|
(hash-ref c k
|
|
(λ ()
|
|
(match k
|
|
["indexes"
|
|
(list "https://plt-etc.byu.edu:9004"
|
|
"https://plt-etc.byu.edu:9003")]))))
|
|
|
|
(define (package-index-lookup pkg)
|
|
(or
|
|
(for/or ([i (in-list (read-pkg-cfg/def "indexes"))])
|
|
(call/input-url+200
|
|
(combine-url/relative
|
|
(string->url i)
|
|
(format "/pkg/~a" pkg))
|
|
read))
|
|
(error 'planet2 "Cannot find package ~a on indexes" pkg)))
|
|
|
|
(define (remote-package-checksum pkg)
|
|
(match pkg
|
|
[`(pns ,pkg-name)
|
|
(hash-ref (package-index-lookup pkg-name) 'checksum)]
|
|
[`(url ,pkg-url-str)
|
|
(package-url->checksum pkg-url-str)]))
|
|
|
|
(define (read-file-hash file)
|
|
(define the-db
|
|
(with-handlers ([exn? (λ (x) (hash))])
|
|
(file->value file)))
|
|
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)
|
|
(read-file-hash (pkg-db-file)))
|
|
|
|
(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
|
|
(error 'planet2 "Package ~e not currently installed; ~e are installed"
|
|
pkg-name
|
|
(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)))
|
|
|
|
(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 (package-directory pkg-name)
|
|
(match-define (pkg-info orig-pkg checksum _)
|
|
(package-info pkg-name))
|
|
(match orig-pkg
|
|
[`(link ,orig-pkg-dir)
|
|
orig-pkg-dir]
|
|
[_
|
|
(build-path (pkg-installed-dir) pkg-name)]))
|
|
|
|
(define (remove-package pkg-name)
|
|
(match-define (pkg-info orig-pkg checksum _)
|
|
(package-info pkg-name))
|
|
(define pkg-dir (package-directory pkg-name))
|
|
(remove-from-pkg-db! pkg-name)
|
|
(match orig-pkg
|
|
[`(link ,_)
|
|
(links pkg-dir
|
|
#:remove? #t
|
|
#:user? (not (current-install-system-wide?))
|
|
#:root? #t)]
|
|
[_
|
|
(links pkg-dir
|
|
#:remove? #t
|
|
#:user? (not (current-install-system-wide?))
|
|
#:root? #t)
|
|
(delete-directory/files pkg-dir)]))
|
|
|
|
(define (remove-packages in-pkgs
|
|
#:force? [force? #f]
|
|
#:auto? [auto? #f])
|
|
(define db (read-pkg-db))
|
|
(define all-pkgs
|
|
(hash-keys db))
|
|
(define all-pkgs-set
|
|
(list->set all-pkgs))
|
|
(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
|
|
all-pkgs))))
|
|
in-pkgs))
|
|
(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
|
|
(set->list
|
|
remaining-pkg-db-set)))))
|
|
(unless (set-empty? deps-to-be-removed)
|
|
(error 'planet2 "Cannot remove packages that are dependencies of other packages: ~e"
|
|
(set->list deps-to-be-removed))))
|
|
(for-each remove-package pkgs))
|
|
|
|
(define (install-packages
|
|
#:old-infos [old-infos empty]
|
|
#:old-auto+pkgs [old-auto+pkgs empty]
|
|
#:pre-succeed [pre-succeed void]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:updating? [updating? #f]
|
|
#:ignore-checksums? [ignore-checksums? #f]
|
|
#:link? [link? #f]
|
|
#:force? [force? #f]
|
|
auto+pkgs)
|
|
(define check-sums? (not ignore-checksums?))
|
|
(define (install-package pkg
|
|
#:pkg-name [given-pkg-name #f])
|
|
(define pkg-url (and (string? pkg) (string->url pkg)))
|
|
(cond
|
|
[(file-exists? 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))
|
|
(error 'pkg "Incorrect checksum on package: expected ~e, got ~e"
|
|
expected-checksum actual-checksum))
|
|
(define checksum
|
|
actual-checksum)
|
|
(define pkg-format (filename-extension pkg))
|
|
(define pkg-name
|
|
(or given-pkg-name
|
|
(regexp-replace
|
|
(regexp
|
|
(format "~a$" (regexp-quote (format ".~a" pkg-format))))
|
|
(path->string (file-name-from-path 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)]
|
|
[#"zip"
|
|
(unzip pkg (make-filesystem-entry-reader #:dest pkg-dir))]
|
|
[#"plt"
|
|
(unplt pkg pkg-dir)]
|
|
[x
|
|
(error 'pkg "Invalid package format: ~e" x)])
|
|
|
|
(update-install-info-checksum
|
|
(update-install-info-orig-pkg
|
|
(install-package pkg-dir
|
|
#:pkg-name pkg-name)
|
|
`(file ,(simple-form-path* pkg)))
|
|
checksum))
|
|
(λ ()
|
|
(delete-directory/files pkg-dir)))]
|
|
[(directory-exists? pkg)
|
|
(let ([pkg (directory-path-no-slash pkg)])
|
|
(define pkg-name
|
|
(or given-pkg-name (path->string (file-name-from-path pkg))))
|
|
(cond
|
|
[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)]))]
|
|
[(url-scheme pkg-url)
|
|
=>
|
|
(lambda (scheme)
|
|
(define orig-pkg `(url ,pkg))
|
|
(define checksum (remote-package-checksum orig-pkg))
|
|
(define info
|
|
(update-install-info-orig-pkg
|
|
(match scheme
|
|
["github"
|
|
(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" branch))
|
|
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-file! new-url tmp.tgz)
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(untar tmp.tgz tmp-dir #:strip-components 1)
|
|
(install-package (path->string package-path)
|
|
#:pkg-name given-pkg-name))
|
|
(λ ()
|
|
(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?
|
|
(string=? "" url-last-component))
|
|
(define-values
|
|
(package-path package-name download-package!)
|
|
(cond
|
|
[url-looks-like-directory?
|
|
(define package-name
|
|
(path/param-path
|
|
(second (reverse (url-path pkg-url)))))
|
|
(define package-path
|
|
(make-temporary-file
|
|
(string-append
|
|
"~a-"
|
|
package-name)
|
|
'directory))
|
|
(define (path-like f)
|
|
(build-path package-path f))
|
|
(define (url-like f)
|
|
(combine-url/relative pkg-url f))
|
|
(values package-path
|
|
package-name
|
|
(λ ()
|
|
(printf "\tCloning remote directory\n")
|
|
(make-directory* package-path)
|
|
(define manifest
|
|
(call/input-url+200
|
|
(url-like "MANIFEST")
|
|
port->lines))
|
|
(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
|
|
(regexp-replace
|
|
#rx"\\.[^.]+$"
|
|
url-last-component
|
|
"")
|
|
(λ ()
|
|
(dprintf "\tAssuming URL names a file\n")
|
|
(download-file! pkg-url package-path)))]))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(download-package!)
|
|
(define pkg-name
|
|
(or given-pkg-name
|
|
package-name))
|
|
(dprintf "\tDownloading done, installing ~a as ~a\n"
|
|
package-path pkg-name)
|
|
(install-package package-path
|
|
#:pkg-name
|
|
pkg-name))
|
|
(λ ()
|
|
(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))
|
|
(error 'planet2 "Remote package ~a had no checksum"
|
|
pkg))
|
|
(when (and checksum
|
|
(install-info-checksum info)
|
|
check-sums?
|
|
(not (equal? (install-info-checksum info) checksum)))
|
|
(error 'planet2 "Incorrect checksum on package ~e: expected ~e, got ~e"
|
|
pkg
|
|
(install-info-checksum info) checksum))
|
|
(update-install-info-checksum
|
|
info
|
|
checksum))]
|
|
[else
|
|
(define index-info (package-index-lookup pkg))
|
|
(define source (hash-ref index-info 'source))
|
|
(define checksum (hash-ref index-info 'checksum))
|
|
(define info (install-package source
|
|
#:pkg-name (or given-pkg-name pkg)))
|
|
(when (and (install-info-checksum info)
|
|
check-sums?
|
|
(not (equal? (install-info-checksum info) checksum)))
|
|
(error 'planet2 "Incorrect checksum on package: ~e" pkg))
|
|
(update-install-info-orig-pkg
|
|
(update-install-info-checksum
|
|
info
|
|
checksum)
|
|
`(pns ,pkg))]))
|
|
(define db (read-pkg-db))
|
|
(define (install-package/outer infos auto+pkg info)
|
|
(match-define (cons auto? pkg)
|
|
auto+pkg)
|
|
(match-define
|
|
(install-info pkg-name orig-pkg pkg-dir clean? checksum)
|
|
info)
|
|
(define pns? (eq? 'pns (first orig-pkg)))
|
|
(define (clean!)
|
|
(when clean?
|
|
(delete-directory/files pkg-dir)))
|
|
(define simultaneous-installs
|
|
(list->set (map install-info-name infos)))
|
|
(cond
|
|
[(and (not updating?) (package-info pkg-name #f))
|
|
(clean!)
|
|
(error 'planet2 "~e is already installed" pkg-name)]
|
|
[(and
|
|
(not force?)
|
|
(for/or ([f (in-list (directory-list* pkg-dir))]
|
|
#:when (member (filename-extension f)
|
|
(list #"rkt" #"ss")))
|
|
(or
|
|
;; Compare with Racket
|
|
(and (file-exists? (build-path (absolute-collects-dir) f))
|
|
(cons "racket" f))
|
|
;; Compare with installed packages
|
|
(for/or ([other-pkg (in-hash-keys db)]
|
|
#:unless (and updating? (equal? other-pkg pkg-name)))
|
|
(define p (build-path (package-directory other-pkg) f))
|
|
(and (file-exists? p)
|
|
(cons other-pkg f)))
|
|
;; Compare with simultaneous installs
|
|
(for/or ([other-pkg-info (in-list infos)]
|
|
#:unless (eq? other-pkg-info info))
|
|
(define p (build-path (install-info-directory other-pkg-info) f))
|
|
(and (file-exists? p)
|
|
(cons (install-info-name other-pkg-info) f))))))
|
|
=>
|
|
(λ (conflicting-pkg*file)
|
|
(clean!)
|
|
(match-define (cons conflicting-pkg file) conflicting-pkg*file)
|
|
(error 'planet2 "~e conflicts with ~e: ~e" pkg conflicting-pkg file))]
|
|
[(and
|
|
(not (eq? dep-behavior 'force))
|
|
(let ()
|
|
(define meta (file->value* (build-path pkg-dir "METADATA.rktd") empty))
|
|
(define deps (dict-ref meta 'dependency empty))
|
|
(define unsatisfied-deps
|
|
(filter-not (λ (dep)
|
|
(or (set-member? simultaneous-installs dep)
|
|
(hash-has-key? db dep)))
|
|
deps))
|
|
(and (not (empty? unsatisfied-deps))
|
|
unsatisfied-deps)))
|
|
=>
|
|
(λ (unsatisfied-deps)
|
|
(match
|
|
(or dep-behavior
|
|
(if pns?
|
|
'search-ask
|
|
'fail))
|
|
['fail
|
|
(clean!)
|
|
(error 'planet2 "missing dependencies: ~e" unsatisfied-deps)]
|
|
['search-auto
|
|
(printf "The following packages are listed as dependencies, but are not currently installed, so we will automatically install them.\n")
|
|
(printf "\t")
|
|
(for ([p (in-list unsatisfied-deps)])
|
|
(printf "~a " p))
|
|
(printf "\n")
|
|
(raise (vector infos unsatisfied-deps))]
|
|
['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 infos unsatisfied-deps))]
|
|
[(or "n" "N")
|
|
(clean!)
|
|
(error 'planet2 "missing dependencies: ~e" unsatisfied-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]))
|
|
(dprintf "creating link to ~e" final-pkg-dir)
|
|
(links final-pkg-dir
|
|
#:user? (not (current-install-system-wide?))
|
|
#:root? #t)
|
|
(define this-pkg-info
|
|
(pkg-info orig-pkg checksum auto?))
|
|
(dprintf "updating db with ~e to ~e" pkg-name this-pkg-info)
|
|
(update-pkg-db! pkg-name this-pkg-info))]))
|
|
(define infos
|
|
(map install-package (map cdr auto+pkgs)))
|
|
(define do-its
|
|
(map (curry install-package/outer (append old-infos infos))
|
|
(append old-auto+pkgs auto+pkgs)
|
|
(append old-infos infos)))
|
|
(pre-succeed)
|
|
(for-each (λ (t) (t)) do-its))
|
|
|
|
(define (install-cmd pkgs
|
|
#:old-infos [old-infos empty]
|
|
#:old-auto+pkgs [old-auto+pkgs empty]
|
|
#:force? [force #f]
|
|
#:link? [link #f]
|
|
#:ignore-checksums? [ignore-checksums #f]
|
|
#:pre-succeed [pre-succeed void]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:updating? [updating? #f])
|
|
(with-handlers ([vector?
|
|
(match-lambda
|
|
[(vector new-infos deps)
|
|
(dprintf "\nInstallation failed with new deps: ~a\n\n"
|
|
deps)
|
|
|
|
(install-cmd
|
|
#:old-infos new-infos
|
|
#:old-auto+pkgs (append old-auto+pkgs pkgs)
|
|
#:force? force
|
|
#:link? link
|
|
#:ignore-checksums? ignore-checksums
|
|
#:dep-behavior dep-behavior
|
|
#:pre-succeed pre-succeed
|
|
#:updating? updating?
|
|
(map (curry cons #t) deps))])])
|
|
(install-packages
|
|
#:old-infos old-infos
|
|
#:old-auto+pkgs old-auto+pkgs
|
|
#:force? force
|
|
#:link? link
|
|
#:ignore-checksums? ignore-checksums
|
|
#:dep-behavior dep-behavior
|
|
#:pre-succeed pre-succeed
|
|
#:updating? updating?
|
|
pkgs)))
|
|
|
|
(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 pkg-name)
|
|
(match-define (pkg-info orig-pkg checksum auto?)
|
|
(package-info pkg-name))
|
|
(match orig-pkg
|
|
[`(link ,_)
|
|
(error 'planet2 "Cannot update linked packages (~e is linked to ~e)"
|
|
pkg-name
|
|
orig-pkg)]
|
|
[`(dir ,_)
|
|
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local directory.)"
|
|
pkg-name)]
|
|
[`(file ,_)
|
|
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local file.)"
|
|
pkg-name)]
|
|
[`(,_ ,orig-pkg-desc)
|
|
(define new-checksum
|
|
(remote-package-checksum orig-pkg))
|
|
(and new-checksum
|
|
(not (equal? checksum new-checksum))
|
|
(cons pkg-name (cons auto? orig-pkg-desc)))]))
|
|
|
|
(define (package-dependencies pkg-name)
|
|
(define pkg-dir (package-directory pkg-name))
|
|
(define meta (file->value* (build-path pkg-dir "METADATA.rktd") empty))
|
|
(dict-ref meta 'dependency empty))
|
|
|
|
(define (update-packages in-pkgs
|
|
#:all? [all? #f]
|
|
#:dep-behavior [dep-behavior #f]
|
|
#:deps? [deps? #f])
|
|
(define pkgs
|
|
(cond
|
|
[(and all? (empty? in-pkgs))
|
|
(filter update-is-possible? (hash-keys (read-pkg-db)))]
|
|
[deps?
|
|
(append-map
|
|
package-dependencies
|
|
in-pkgs)]
|
|
[else
|
|
in-pkgs]))
|
|
(define to-update (filter-map update-package pkgs))
|
|
(cond
|
|
[(empty? to-update)
|
|
(printf "No updates available\n")
|
|
#f]
|
|
[else
|
|
(install-cmd
|
|
#:updating? #t
|
|
#:pre-succeed (λ () (for-each (compose remove-package car) to-update))
|
|
#:dep-behavior dep-behavior
|
|
(map cdr to-update))
|
|
#t]))
|
|
|
|
(define (show-cmd)
|
|
(let ()
|
|
(define db (read-pkg-db))
|
|
(define pkgs (sort (hash-keys db) string-ci<=?))
|
|
(table-display
|
|
(list*
|
|
(list "Package(auto?)" "Checksum" "Source")
|
|
(for/list ([pkg (in-list pkgs)])
|
|
(match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg))
|
|
(list (format "~a~a"
|
|
pkg
|
|
(if auto?
|
|
"*"
|
|
""))
|
|
(format "~a" checksum)
|
|
(format "~a" orig-pkg)))))))
|
|
|
|
(define (config-cmd config:set key+vals)
|
|
(cond
|
|
[config:set
|
|
(match key+vals
|
|
[(list* (and key "indexes") val)
|
|
(update-pkg-cfg! "indexes" val)]
|
|
[(list key)
|
|
(error 'planet2 "unsupported config key: ~e" key)]
|
|
[(list)
|
|
(error 'planet2 "must provide config key")])]
|
|
[else
|
|
(match key+vals
|
|
[(list key)
|
|
(match key
|
|
["indexes"
|
|
(for ([s (in-list (read-pkg-cfg/def "indexes"))])
|
|
(printf "~a\n" s))]
|
|
[_
|
|
(error 'planet2 "unsupported config key: ~e" key)])]
|
|
[(list)
|
|
(error 'planet2 "must provide config key")]
|
|
[_
|
|
(error 'planet2 "must provide only config key")])]))
|
|
|
|
(define (create-cmd create:format maybe-dir)
|
|
(begin
|
|
(define dir (regexp-replace* #rx"/$" maybe-dir ""))
|
|
(unless (directory-exists? dir)
|
|
(error 'planet2 "directory does not exist: ~e" dir))
|
|
(match create:format
|
|
["MANIFEST"
|
|
(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))
|
|
(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"
|
|
(pack-plt pkg pkg-name (list dir)
|
|
#:as-paths (list "."))]
|
|
[x
|
|
(error 'pkg "Invalid package format: ~e" x)])
|
|
(define chk (format "~a.CHECKSUM" pkg))
|
|
(with-output-to-file chk #:exists 'replace
|
|
(λ () (display (call-with-input-file pkg sha1))))])))
|
|
|
|
(define dep-behavior/c
|
|
(or/c false/c
|
|
(symbols 'fail 'force 'search-ask 'search-auto)))
|
|
|
|
(provide
|
|
with-package-lock
|
|
(contract-out
|
|
[current-install-system-wide?
|
|
(parameter/c boolean?)]
|
|
[config-cmd
|
|
(-> boolean? list?
|
|
void)]
|
|
[create-cmd
|
|
(-> string? path-string?
|
|
void)]
|
|
[update-packages
|
|
(->* ((listof string?))
|
|
(#:dep-behavior dep-behavior/c
|
|
#:all? boolean?
|
|
#:deps? boolean?)
|
|
boolean?)]
|
|
[remove-packages
|
|
(->* ((listof string?))
|
|
(#:auto? boolean?
|
|
#:force? boolean?)
|
|
void)]
|
|
[show-cmd
|
|
(-> void)]
|
|
[install-cmd
|
|
(->* ((listof (cons/c boolean? string?)))
|
|
(#:dep-behavior dep-behavior/c
|
|
#:force? boolean?
|
|
#:link? boolean?
|
|
#:ignore-checksums? boolean?)
|
|
void)]))
|