From 5650e8fc03d73d262aac1a9dc0846480b906e2fa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Oct 2014 17:14:46 -0600 Subject: [PATCH] reorganize `pkg/lib` implementation Split the module into several (smaller) modules. --- .../racket-test/tests/pkg/tests-basic.rkt | 1 - .../racket-test/tests/pkg/tests-checksums.rkt | 1 - .../racket-test/tests/pkg/tests-conflicts.rkt | 1 - .../racket-test/tests/pkg/tests-create.rkt | 1 - .../racket-test/tests/pkg/tests-deps.rkt | 1 - .../racket-test/tests/pkg/tests-failure.rkt | 1 - .../racket-test/tests/pkg/tests-install.rkt | 1 - .../racket-test/tests/pkg/tests-network.rkt | 1 - .../racket-test/tests/pkg/tests-platform.rkt | 1 - .../racket-test/tests/pkg/tests-promote.rkt | 1 - .../racket-test/tests/pkg/tests-remove.rkt | 1 - .../racket-test/tests/pkg/tests-update.rkt | 1 - .../racket-test/tests/pkg/tests-versions.rkt | 1 - .../racket-test/tests/pkg/util.rkt | 1 - racket/collects/pkg/lib.rkt | 3851 +---------------- racket/collects/pkg/private/addl-installs.rkt | 154 + racket/collects/pkg/private/archive.rkt | 175 + .../collects/pkg/private/catalog-archive.rkt | 125 + racket/collects/pkg/private/catalog-copy.rkt | 162 + racket/collects/pkg/private/catalog-show.rkt | 82 + .../collects/pkg/private/catalog-update.rkt | 81 + racket/collects/pkg/private/catalog.rkt | 306 ++ racket/collects/pkg/private/collects.rkt | 71 + racket/collects/pkg/private/config.rkt | 202 + racket/collects/pkg/private/content.rkt | 50 + racket/collects/pkg/private/create.rkt | 196 + racket/collects/pkg/private/dep.rkt | 36 + racket/collects/pkg/private/desc.rkt | 15 + racket/collects/pkg/private/dirs.rkt | 38 + racket/collects/pkg/private/download.rkt | 87 + racket/collects/pkg/private/get-info.rkt | 32 + racket/collects/pkg/private/install.rkt | 1024 +++++ racket/collects/pkg/private/lock.rkt | 71 + racket/collects/pkg/private/metadata.rkt | 120 + racket/collects/pkg/private/migrate.rkt | 71 + racket/collects/pkg/private/mod-paths.rkt | 84 + racket/collects/pkg/private/params.rkt | 29 + racket/collects/pkg/private/path.rkt | 85 + racket/collects/pkg/private/pkg-db.rkt | 220 + racket/collects/pkg/private/print.rkt | 37 + racket/collects/pkg/private/remove.rkt | 152 + racket/collects/pkg/private/show.rkt | 69 + racket/collects/pkg/private/stage.rkt | 598 +++ racket/collects/pkg/private/suggestions.rkt | 39 + racket/collects/pkg/util.rkt | 208 - 45 files changed, 4436 insertions(+), 4048 deletions(-) create mode 100644 racket/collects/pkg/private/addl-installs.rkt create mode 100644 racket/collects/pkg/private/archive.rkt create mode 100644 racket/collects/pkg/private/catalog-archive.rkt create mode 100644 racket/collects/pkg/private/catalog-copy.rkt create mode 100644 racket/collects/pkg/private/catalog-show.rkt create mode 100644 racket/collects/pkg/private/catalog-update.rkt create mode 100644 racket/collects/pkg/private/catalog.rkt create mode 100644 racket/collects/pkg/private/collects.rkt create mode 100644 racket/collects/pkg/private/config.rkt create mode 100644 racket/collects/pkg/private/content.rkt create mode 100644 racket/collects/pkg/private/create.rkt create mode 100644 racket/collects/pkg/private/dep.rkt create mode 100644 racket/collects/pkg/private/desc.rkt create mode 100644 racket/collects/pkg/private/dirs.rkt create mode 100644 racket/collects/pkg/private/download.rkt create mode 100644 racket/collects/pkg/private/get-info.rkt create mode 100644 racket/collects/pkg/private/install.rkt create mode 100644 racket/collects/pkg/private/lock.rkt create mode 100644 racket/collects/pkg/private/metadata.rkt create mode 100644 racket/collects/pkg/private/migrate.rkt create mode 100644 racket/collects/pkg/private/mod-paths.rkt create mode 100644 racket/collects/pkg/private/params.rkt create mode 100644 racket/collects/pkg/private/path.rkt create mode 100644 racket/collects/pkg/private/pkg-db.rkt create mode 100644 racket/collects/pkg/private/print.rkt create mode 100644 racket/collects/pkg/private/remove.rkt create mode 100644 racket/collects/pkg/private/show.rkt create mode 100644 racket/collects/pkg/private/stage.rkt create mode 100644 racket/collects/pkg/private/suggestions.rkt delete mode 100644 racket/collects/pkg/util.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-basic.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-basic.rkt index 11a6eeacdb..7d3cce4d54 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-basic.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-basic.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-checksums.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-checksums.rkt index 186e8fa863..bee0dca8a7 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-checksums.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-checksums.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-conflicts.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-conflicts.rkt index 30e6975cb0..885ee692e7 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-conflicts.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-conflicts.rkt @@ -9,7 +9,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-create.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-create.rkt index 22e433f89d..bc85eaa279 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-create.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-create.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt index 1179600365..4fbbb88e81 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-failure.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-failure.rkt index 203f498c91..36bceb3d8a 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-failure.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-failure.rkt @@ -1,7 +1,6 @@ #lang racket/base (require rackunit racket/system - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt index 0a8a7999ac..e388eae1a9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt @@ -12,7 +12,6 @@ file/zip file/unzip net/url - pkg/util setup/dirs "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt index 3e58879e1a..abf9f649e4 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-platform.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-platform.rkt index b3ee22daaa..15629397d9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-platform.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-platform.rkt @@ -2,7 +2,6 @@ (require rackunit racket/file racket/format - pkg/util (prefix-in db: pkg/db) "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt index e95c49b812..6a2bcf3892 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt @@ -1,7 +1,6 @@ #lang racket/base (require rackunit racket/system - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt index 9281894d88..8a4329acf4 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-update.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-update.rkt index a29c806a55..32cc4c0b3f 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-update.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-update.rkt @@ -9,7 +9,6 @@ racket/path racket/list racket/format - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-versions.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-versions.rkt index f0bea21ac6..f3e38b16c6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-versions.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-versions.rkt @@ -8,7 +8,6 @@ racket/runtime-path racket/path racket/list - pkg/util "shelly.rkt" "util.rkt") diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt index ff3694645f..3220ecb1fe 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt @@ -10,7 +10,6 @@ racket/list racket/format setup/dirs - pkg/util "shelly.rkt") (define-runtime-path test-directory ".") diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index f8c28cace5..1e8304fb1c 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -1,3831 +1,30 @@ #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 - setup/collection-name - setup/matching-platform - racket/port - racket/list - racket/function - racket/dict - racket/set - racket/string - file/untgz - file/tar - file/zip - file/unzip - file/cache - setup/getinfo - setup/dirs - racket/format - version/utils - syntax/modcollapse - syntax/modread - compiler/compilation-path - "name.rkt" - "util.rkt" - "strip.rkt" +(require racket/contract/base + net/url "path.rkt" - (prefix-in db: "db.rkt")) - -(define current-pkg-scope - (make-parameter 'user (lambda (p) - (if (path? p) - (simple-form-path p) - p)))) -(define current-pkg-scope-version - (make-parameter (get-installation-name))) -(define current-pkg-lookup-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 current-pkg-download-cache-dir - (make-parameter #f)) -(define current-pkg-download-cache-max-files - (make-parameter #f)) -(define current-pkg-download-cache-max-bytes - (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))) - -(define (printf/flush fmt . args) - ;; For status reporting, flush immediately after printing - (apply printf fmt args) - (flush-output)) - -(struct pkg-desc (source type name checksum auto?)) -(define (pkg-desc=? a b) - (define (->list a) - (list (pkg-desc-source a) - (pkg-desc-type a) - (pkg-desc-name a) - (pkg-desc-checksum a) - (pkg-desc-auto? a))) - (equal? (->list a) (->list b))) - -(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 (pretty-module-path 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 (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 checksum - #:download-printf [download-printf #f] - #:use-cache? [use-cache? #t] - #: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) - (define (download!) - (when download-printf - (download-printf "Downloading ~a\n" (url->string url))) - (call-with-output-file file - (λ (op) - (call/input-url+200 - url - (λ (ip) (copy-port ip op)) - #:failure - (lambda (reply-s) - (pkg-error (~a "error downloading package\n" - " URL: ~a\n" - " server response: ~a") - (url->string url) - (read-line (open-input-string reply-s)))))))) - (cond - [(and checksum use-cache?) - (cache-file file - (list (url->string url) checksum) - (get-download-cache-dir) - download! - #:log-error-string (lambda (s) (log-pkg-error s)) - #:log-debug-string (lambda (s) (log-pkg-debug s)) - #:notify-cache-use (lambda (s) - (when download-printf - (download-printf "Using ~a for ~a\n" - s - (url->string url)))) - #:max-cache-files (get-download-cache-max-files) - #:max-cache-size (get-download-cache-max-bytes))] - [else (download!)]))) - -(define (clean-cache pkg-url checksum) - (when pkg-url - ;; Something failed after download, so remove cached file (if any): - (with-handlers ([exn:fail? void]) ; any error is logged already - (cache-remove (list (url->string pkg-url) checksum) - (get-download-cache-dir) - #:log-error-string (lambda (s) (log-pkg-error s)) - #:log-debug-string (lambda (s) (log-pkg-debug s)))))) - -(define (pkg-dir config?) - (define scope (current-pkg-scope)) - (if (and config? - (eq? scope 'installation)) - (find-config-dir) - (get-pkgs-dir scope (current-pkg-scope-version)))) -(define (pkg-config-file) - (build-path (pkg-dir #t) "config.rktd")) -(define (pkg-db-file) - (build-path (pkg-dir #f) "pkgs.rktd")) -(define (pkg-installed-dir) - (pkg-dir #f)) -(define (pkg-lock-file) - (make-lock-file-name (pkg-db-file))) - -(define (get-download-cache-dir) - (or (current-pkg-download-cache-dir) - (read-pkg-cfg/def 'download-cache-dir))) -(define (get-download-cache-max-files) - (or (current-pkg-download-cache-max-files) - (read-pkg-cfg/def 'download-cache-max-files))) -(define (get-download-cache-max-bytes) - (or (current-pkg-download-cache-max-bytes) - (read-pkg-cfg/def 'download-cache-max-bytes))) - -(define (make-metadata-namespace) - (make-base-empty-namespace)) - -(define (get-pkg-info pkg-dir metadata-ns) - (with-handlers ([exn:fail? (λ (x) - (log-exn x "getting info") - #f)]) - (get-info/full pkg-dir - #:namespace metadata-ns - #:bootstrap? #t))) - -(define (get-metadata metadata-ns pkg-dir key get-default - #:checker [checker void]) - (define get-info (get-pkg-info pkg-dir 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 which) 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 `" which "' specification\n" - " specification: ~e") - deps))) - -(define (get-all-deps* metadata-ns pkg-dir) - (values - (get-metadata metadata-ns pkg-dir - 'deps (lambda () empty) - #:checker (check-dependencies 'deps)) - (get-metadata metadata-ns pkg-dir - 'build-deps (lambda () empty) - #:checker (check-dependencies 'build-deps)))) - -(define (get-all-deps metadata-ns pkg-dir) - (define-values (deps build-deps) (get-all-deps* metadata-ns pkg-dir)) - (append deps build-deps)) - -(define (get-all-deps-subset key metadata-ns pkg-dir deps) - (get-metadata metadata-ns pkg-dir - key (lambda () empty) - #:checker (lambda (l) - (unless (null? l) - (define deps-set (list->set - (map dependency->name deps))) - (unless (and (list? l) - (andmap (lambda (v) - (or (string? v) - (eq? v 'core))) - l)) - (pkg-error (~a "invalid `~a' specification\n" - " specification: ~e") - key - l)) - (unless (andmap (lambda (i) - (or (eq? i 'core) - (set-member? deps-set i))) - l) - (pkg-error (~a "`~a' is not a subset of dependencies\n" - " specification: ~e") - key - l)))))) - -(define (get-all-implies metadata-ns pkg-dir deps) - (get-all-deps-subset 'implies metadata-ns pkg-dir deps)) - -(define (get-all-update-implies metadata-ns pkg-dir deps) - (get-all-deps-subset 'update-implies metadata-ns pkg-dir 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)) - (or (not p) (matching-platform? p))) - -(define pkg-lock-held (make-parameter #f)) -(define pkg-lock-scope (make-parameter #f)) - -;; Call `t' with lock held for the current scope. The intent is that -;; `t' reads and writes package information in the curent scope. It -;; may also *read* package information for wider package scopes -;; without a further lock --- which is questionable, but modification -;; of a shared scope while others are running can create trouble, -;; anyway. -(define (with-pkg-lock* read-only? t) - (define mode (if read-only? 'shared 'exclusive)) - (define held-mode (pkg-lock-held)) - (define now-scope (current-pkg-scope)) - (define held-scope (pkg-lock-scope)) - (when (and held-scope - (not (eq? held-scope now-scope))) - (pkg-error "lock mismatch\n held scope: ~a\n requested scope: ~a" - held-scope - now-scope)) - (if (or (eq? mode held-mode) - (eq? 'exclusive held-mode)) - (t) - (let ([d (pkg-dir #f)]) - (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] - [pkg-lock-scope now-scope] - [current-no-pkg-db #f]) - (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 now-scope]) - (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 (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 #f])] - [else (server i)])) - -;; Add current package version to a URL: -(define (add-version-query addr/no-query) - (struct-copy url addr/no-query - [query (append - (url-query addr/no-query) - (list - (cons 'version (current-pkg-lookup-version))))])) - -;; Take a package-info hash table and lift any version-specific -;; information in 'versions. -(define (select-info-version ht) - (and ht - (let ([v (hash-ref ht 'versions #f)]) - (cond - [(hash? v) - (or (for/or ([vers (in-list (list (current-pkg-lookup-version) - 'default))]) - (define ht2 (hash-ref v vers #f)) - (and ht2 - ;; Override fields of `ht' with values from `ht2': - (for/fold ([ht ht]) ([(k v) (in-hash ht2)]) - (hash-set ht k v)))) - ;; Keep ht as-is: - ht)] - [else ht])))) - -;; If the 'source field in `ht` is a relative path, treat -;; it as relative to `i` and make it absolute: -(define (source->absolute-source i ht) - (cond - [ht - (define s (hash-ref ht 'source #f)) - (define new-ht - (cond - [s - ;; If `s' is a relative URL, then we rely on the pun - ;; that it will parse as a relative path. - (define-values (name type) (package-source->name+type s #f)) - (cond - [(and (or (eq? type 'dir) (eq? type 'file)) - (not (regexp-match? #rx"^file://" s)) - (relative-path? s)) - (define i-for-combine - (cond - [(equal? "file" (url-scheme i)) - (define i-path (url->path i)) - (if (db-path? i-path) - i - ;; Make sure we interpret `i' as a directory when - ;; adding a relative path: - (path->url (path->directory-path (url->path i))))] - [else i])) - (define full-url - (url->string - (combine-url/relative i-for-combine s))) - (hash-set ht 'source full-url)] - [else ht])] - [else ht])) - (let ([v (hash-ref new-ht 'versions #f)]) - (if v - ;; Adjust version-specific sources: - (hash-set new-ht 'versions - (for/hash ([(k ht) (in-hash v)]) - (values k (source->absolute-source i ht)))) - ;; No further adjustments: - new-ht))] - [else #f])) - -;; Make sources in `ht` relative to `dir`, when possible: -(define (source->relative-source dir ht) - (define s (hash-ref ht 'source #f)) - (define new-ht - (cond - [s - (define-values (name type) (package-source->name+type s #f)) - (cond - [(or (eq? type 'dir) (eq? type 'file)) - (hash-set ht - 'source - (relative-path->relative-url-string - (find-relative-path - dir - (package-source->path s type))))] - [else ht])] - [else ht])) - (let ([v (hash-ref new-ht 'versions #f)]) - (if v - ;; Adjust version-specific sources: - (hash-set new-ht 'versions - (for/hash ([(k ht) (in-hash new-ht)]) - (values k (source->relative-source dir ht)))) - ;; No further adjustments: - new-ht))) - -(define (package-catalog-lookup pkg details? download-printf) - (or - (for/or ([i (in-list (pkg-catalogs))]) - (if download-printf - (download-printf "Resolving ~s via ~a\n" pkg (url->string i)) - (log-pkg-debug "consulting catalog ~a" (url->string i))) - (source->absolute-source - i - (select-info-version - (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-checksum pkg)))) - -(define (remote-package-checksum pkg download-printf pkg-name) - (match pkg - [`(catalog ,pkg-name) - (hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)] - [`(url ,pkg-url-str) - (package-url->checksum pkg-url-str - #:download-printf download-printf - #:pkg-name pkg-name)])) - -(define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf) - (case type - [(file-url dir-url github) - (or given-checksum - (remote-package-checksum `(url ,pkg-source) download-printf pkg-name))] - [(file) - (define checksum-pth (format "~a.CHECKSUM" pkg-source)) - (or (and (file-exists? checksum-pth) - (file->string checksum-pth)) - (and (file-exists? pkg-source) - (call-with-input-file* pkg-source sha1)))] - [else given-checksum])) - -(define (write-file-hash! file new-db) - (unless (eq? (pkg-lock-held) 'exclusive) - (pkg-error "attempt to write package database without write lock")) - (make-parent-directory* file) - (call-with-atomic-output-file - file - (λ (o tmp-path) (write new-db o) (newline o)))) - -(define (read-pkg-db) - (unless (pkg-lock-held) - (pkg-error "attempt to read package database without lock")) - (define scope (current-pkg-scope)) - (if (eq? (current-no-pkg-db) scope) - #hash() - (read-pkgs-db scope (current-pkg-scope-version)))) - -;; read all packages in this scope or wider -(define (merge-pkg-dbs [scope (current-pkg-scope)]) - (define (merge-next-pkg-dbs scope) - (parameterize ([current-pkg-scope scope]) - (merge-pkg-dbs scope))) - (if (path? scope) - (read-pkg-db) - (case scope - [(installation) - (for*/hash ([dir (in-list (get-pkgs-search-dirs))] - [(k v) (read-pkgs-db dir)]) - (values k v))] - [(user) - (define db (read-pkgs-db 'user (current-pkg-scope-version))) - (for/fold ([ht (merge-next-pkg-dbs 'installation)]) ([(k v) (in-hash db)]) - (hash-set ht k v))]))) - -;; Finds the scope, in which `pkg-name' is installed; returns 'dir, -;; 'installation, a path, or #f (where #f means "not installed"). If -;; `next?' is true, search only scopes wider than the current one. -(define (find-pkg-installation-scope pkg-name #:next? [next? #f]) - (case (current-pkg-scope) - [(user) - (or (and (not next?) - (hash-ref (read-pkg-db) pkg-name #f) - 'user) - (parameterize ([current-pkg-scope 'installation]) - (find-pkg-installation-scope pkg-name)))] - [(installation) - (or (and (not next?) - (hash-ref (read-pkg-db) pkg-name #f) - 'installation) - (for/or ([dir (in-list (get-pkgs-search-dirs))]) - (and (hash-ref (read-pkgs-db dir) pkg-name #f) - dir)))] - [else - (and (not next?) - (and (hash-ref (read-pkgs-db (current-pkg-scope)) pkg-name #f) - (current-pkg-scope)))])) - -(define (package-info pkg-name [fail? #t] #:db [given-db #f]) - (define db (or given-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 -(define (current-scope->string) - (define scope (current-pkg-scope)) - (cond - [(path? scope) (path->string scope)] - [else (symbol->string scope)])) - -;; prints an error for packages that are not installed -;; pkg-name db -> void -(define (pkg-not-installed pkg-name db) - ;; This may read narrower package scopes without holding the - ;; lock, but maybe that's ok for mere error reporting: - (define s (parameterize ([current-pkg-scope 'user]) - (find-pkg-installation-scope pkg-name))) - - (define not-installed-msg - (cond [s "package installed in a different scope"] - [else "package not currently installed"])) - - (apply pkg-error (~a not-installed-msg - "\n package: ~a" - "\n current scope: ~a" - (if s - "\n installed in scope: ~a" - "") - ;; Probably too much information: - #; - "\n packages in current scope:~a") - (append - (list - pkg-name - (current-scope->string)) - (if s (list s) null) - #; - (list - (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/def k) - ;; Lock is held for the current scope, but if - ;; the key is not found in the current scope, - ;; get the next scope's lock and try there, - ;; etc. - (define (get-default) - (match k - ['catalogs - (list "http://pkgs.racket-lang.org" - "http://planet-compats.racket-lang.org")] - ['default-scope "user"] - ['installation-name (version)] - ['download-cache-dir (build-path (find-system-path 'addon-dir) - "download-cache")] - ['download-cache-max-files 1024] - ['download-cache-max-bytes (* 64 1024 1024)] - [_ #f])) - (define c (read-pkg-file-hash (pkg-config-file))) - (define v (hash-ref c k 'none)) - (cond - [(eq? v 'none) - ;; Default from enclosing scope or hard-wired default: - (define s (current-pkg-scope)) - (if (eq? s 'installation) - ;; Hard-wided: - (get-default) - ;; Enclosing: - (parameterize ([current-pkg-scope 'installation]) - (read-pkg-cfg/def k)))] - [else - (match k - ['catalogs - (if (member #f v) - ;; Replace #f with default URLs: - (apply append (for/list ([i (in-list v)]) - (if (not i) - (get-default) - (list i)))) - v)] - [_ v])])) - -(define (update-pkg-cfg! key val) - (define f (pkg-config-file)) - (write-file-hash! - f - (hash-set (read-pkg-file-hash f) key val))) - -(define (default-pkg-scope) - (match (default-pkg-scope-as-string) - ["installation" 'installation] - [else 'user])) -(define (default-pkg-scope-as-string) - (read-pkg-cfg/def 'default-scope)) - -(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)))) - -(struct install-info (name orig-pkg directory clean? checksum module-paths additional-installs)) - -(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 (scope->links-file scope) - (and (path? scope) - (build-path scope "links.rktd"))) - -(define (get-scope-list) - ;; Get a list of scopes suitable for searches with respect to - ;; the current scope - (define current-scope (current-pkg-scope)) - (if (path? current-scope) - (list current-scope) - (member current-scope - (append '(user) - (let ([main (find-pkgs-dir)]) - (for/list ([d (get-pkgs-search-dirs)]) - (if (equal? d main) - 'installation - d))))))) - -(define (pkg-directory pkg-name) - ;; Warning: takes locks individually. - (pkg-directory** pkg-name - (lambda (f) - (with-pkg-lock/read-only - (f))))) - -(define (pkg-directory** pkg-name [call-with-pkg-lock (lambda (f) (f))]) - (for/or ([scope (in-list (get-scope-list))]) - (parameterize ([current-pkg-scope scope]) - (call-with-pkg-lock - (lambda () - (pkg-directory* pkg-name)))))) - -(define (pkg-directory* pkg-name #:db [db #f]) - (define info (package-info pkg-name #f #:db db)) - (and info - (let () - (match-define (pkg-info orig-pkg checksum _) info) - (match orig-pkg - [`(,(or 'link 'static-link) ,orig-pkg-dir) - (path->complete-path orig-pkg-dir (pkg-installed-dir))] - [_ - (build-path (pkg-installed-dir) - (or (cond - [(pkg-info/alt? info) - (pkg-info/alt-dir-name info)] - [(sc-pkg-info/alt? info) - (sc-pkg-info/alt-dir-name info)] - [else #f]) - pkg-name))])))) - -(define (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name) - ;; Picks the right structure subtype - (if single-collect - (if alt-dir-name - (sc-pkg-info/alt orig-pkg checksum auto? single-collect alt-dir-name) - (sc-pkg-info orig-pkg checksum auto? single-collect)) - (if alt-dir-name - (pkg-info/alt orig-pkg checksum auto? alt-dir-name) - (pkg-info orig-pkg checksum auto?)))) - -(define (update-auto this-pkg-info auto?) - (match-define (pkg-info orig-pkg checksum _) this-pkg-info) - (make-pkg-info orig-pkg checksum auto? - (and (sc-pkg-info? this-pkg-info) - (sc-pkg-info-collect this-pkg-info)) - (or (and (sc-pkg-info/alt? this-pkg-info) - (sc-pkg-info/alt-dir-name this-pkg-info)) - (and (pkg-info/alt? this-pkg-info) - (pkg-info/alt-dir-name this-pkg-info))))) - -(define (demote-packages quiet? pkg-names) - (define db (read-pkg-db)) - (for ([pkg-name (in-list pkg-names)]) - (define pi (package-info pkg-name #:db db)) - (unless (pkg-info-auto? pi) - (unless quiet? - (printf/flush "Demoting ~a to auto-installed\n" pkg-name)) - (update-pkg-db! pkg-name (update-auto pi #t))))) - -(define ((remove-package quiet?) pkg-name) - (unless quiet? - (printf/flush "Removing ~a\n" pkg-name)) - (define db (read-pkg-db)) - (define pi (package-info pkg-name #:db db)) - (match-define (pkg-info orig-pkg checksum _) pi) - (define pkg-dir (pkg-directory* pkg-name #:db db)) - (remove-from-pkg-db! pkg-name) - (define scope (current-pkg-scope)) - (define user? (not (or (eq? scope 'installation) - (path? scope)))) - (match orig-pkg - [`(,(or 'link 'static-link) ,_) - (links pkg-dir - #:remove? #t - #:user? user? - #:file (scope->links-file scope) - #:root? (not (sc-pkg-info? pi)))] - [_ - (links pkg-dir - #:remove? #t - #:user? user? - #:file (scope->links-file scope) - #:root? (not (sc-pkg-info? pi))) - (delete-directory/files pkg-dir)])) - - - -(define (pkg-remove given-pkgs - #:demote? [demote? #f] - #:force? [force? #f] - #:auto? [auto? #f] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #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 in-pkgs (remove-duplicates given-pkgs)) - (define remove-pkgs - (if auto? - ;; compute fixpoint: - (let ([init-drop (set-union - (list->set - (filter - (λ (p) (pkg-info-auto? (hash-ref db p))) - all-pkgs)) - (list->set in-pkgs))]) - (let loop ([drop init-drop] - [keep (set-subtract - (list->set all-pkgs) - init-drop)]) - (define deps - (list->set - (append-map (package-dependencies metadata-ns db #t) - (set->list keep)))) - (define still-drop (set-subtract drop deps)) - (define delta (set-subtract drop still-drop)) - (if (set-empty? delta) - (set->list drop) - (loop still-drop - (set-union keep delta))))) - ;; just given pkgs: - (if demote? - null - in-pkgs))) - (define setup-collects - (get-setup-collects remove-pkgs - db - metadata-ns)) - (unless (or force? demote?) - ;; Check dependencies on `in-pkgs' (not `pkgs', which has already - ;; been filtered to remove package with dependencies if `auto?' is - ;; true). - (define pkgs-set (list->set in-pkgs)) - (define remaining-pkg-db-set - (set-subtract all-pkgs-set - (if auto? - (list->set remove-pkgs) - pkgs-set))) - (define deps-to-be-removed - (set-intersect - pkgs-set - (list->set - (append-map (package-dependencies metadata-ns db #t) - (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 db #t) dp))) - (set->list - remaining-pkg-db-set))) - (~a p " (required by: " ds ")")) - (set->list deps-to-be-removed)))))) - - (when demote? - ;; Demote any package that is not going to be removed: - (demote-packages - quiet? - (set->list (set-subtract (list->set in-pkgs) - (list->set remove-pkgs))))) - - (for-each (remove-package quiet?) - remove-pkgs) - - (cond - [(or (null? remove-pkgs) demote?) - ;; Did nothing, so no setup: - 'skip] - [else - ;; 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))])) - -(define (complain-about-source s reason) - (pkg-error (~a "invalid package source;\n" - " ~a\n" - " given: ~a") - reason - s)) - -(define (check-checksum given-checksum checksum what pkg-src cached-url) - (when (and given-checksum - checksum - (not (equal? given-checksum checksum))) - (clean-cache cached-url checksum) - (pkg-error (~a "~a checksum on package\n" - " package source: ~a\n" - " expected: ~e\n" - " got: ~e") - what - pkg-src - given-checksum - checksum))) - -(define (drop-redundant-files pkg-dir) - ;; Ad hoc space-saving rule: for an installation-wide package, remove - ;; any redundant "COPYING.txt" or "COPYING_LESSER.txt" files. - (when (and (eq? 'installation (current-pkg-scope)) - (find-share-dir)) - (for ([i (in-list '("COPYING.txt" "COPYING_LESSER.txt"))]) - (define pkg-file (build-path pkg-dir i)) - (define share-file (build-path (find-share-dir) i)) - (when (and (file-exists? pkg-file) - (file-exists? share-file) - (equal? (file->bytes pkg-file) - (file->bytes share-file))) - ;; This file would be redundant, so drop it - (delete-file pkg-file))))) - -(define (disallow-package-path-overlaps pkg-name - pkg-path - path-pkg-cache - simultaneous-installs) - (define simple-pkg-path (simple-form-path pkg-path)) - (define (one-in-the-other? p1 p2) - (define pe (explode-path p1)) - (define e (explode-path p2)) - (if ((length e) . < . (length pe)) - (equal? (take pe (length e)) e) - (equal? (take e (length pe)) pe))) - ;; Check collects: - (for ([c (in-list (current-library-collection-paths))]) - (when (one-in-the-other? simple-pkg-path - (simple-form-path c)) - (pkg-error (~a "cannot link a directory that overlaps with a collection path\n" - " collection path: ~a\n" - " link path: ~a\n" - " as package: ~a") - c - pkg-path - pkg-name))) - ;; Check installed packages: - (for ([f (in-directory simple-pkg-path)]) - (define found-pkg (path->pkg f #:cache path-pkg-cache)) - (when (and found-pkg - (not (equal? found-pkg pkg-name))) - (pkg-error (~a "cannot link a directory that overlaps with existing packages\n" - " existing package: ~a\n" - " overlapping path: ~a\n" - " a package: ~a") - found-pkg - f - pkg-name))) - ;; Check simultaneous installs: - (for ([(other-pkg other-dir) (in-hash simultaneous-installs)]) - (unless (equal? other-pkg pkg-name) - (when (one-in-the-other? simple-pkg-path - (simple-form-path other-dir)) - (pkg-error (~a "cannot link directories that overlap for different packages\n" - " package: ~a\n" - " path: ~a\n" - " overlapping package: ~a\n" - " overlapping path: ~a") - pkg-name - pkg-path - other-pkg - other-dir))))) - -;; 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] - #:cached-url [cached-url #f] - #:use-cache? use-cache? - check-sums? - download-printf - metadata-ns - #:strip [strip-mode #f] - #:force-strip? [force-strip? #f] - #:in-place? [in-place? #f] - #:in-place-clean? [in-place-clean? #f] - #:link-dirs? [link-dirs? #f]) - (define-values (inferred-pkg-name type) - (if (path? pkg) - (package-source->name+type (path->string pkg) - (or given-type - (if (directory-exists? pkg) - (if link-dirs? - 'link - 'dir) - 'file)) - #:must-infer-name? (not given-pkg-name) - #:complain complain-about-source) - (package-source->name+type pkg given-type - #:link-dirs? link-dirs? - #:must-infer-name? (not given-pkg-name) - #:complain complain-about-source))) - (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"^git(?:hub)?://" pkg))) - ;; Add "git://github.com/" - (stage-package/info (string-append "git://github.com/" pkg) type - pkg-name - #:given-checksum given-checksum - #:use-cache? use-cache? - check-sums? download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip?)] - [(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 found-checksum - ;; If a checksum is given, use that. In the case of a non-github - ;; source, we could try to get the checksum from the source, and - ;; then check whether it matches the expected one, but we choose - ;; to avoid an extra trip to the server. - (or given-checksum - (remote-package-checksum orig-pkg download-printf pkg-name))) - (when check-sums? - (check-checksum given-checksum found-checksum "unexpected" pkg #f)) - (define checksum (or found-checksum given-checksum)) - (define downloaded-info - (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)) - (when (equal? checksum "") - (pkg-error - (~a "cannot use empty checksum for GitHub package source\n" - " source: ~a") - pkg)) - (match-define (list* user repo branch path) - (split-github-url 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)) - - (dynamic-wind - void - (λ () - (download-file! new-url tmp.tgz checksum - #:use-cache? use-cache? - #:download-printf download-printf) - (define staged? #f) - (dynamic-wind - void - (λ () - (untar tmp.tgz tmp-dir #:strip-components 1) - - (unless (null? path) - (unless (directory-exists? (apply build-path tmp-dir path)) - (pkg-error - (~a "specified directory is not in GitHub respository archive\n" - " path: ~a" - (apply build-path path)))) - (lift-directory-content tmp-dir path)) - - (begin0 - (stage-package/info tmp-dir - 'dir - pkg-name - #:given-checksum checksum - #:cached-url new-url - #:use-cache? use-cache? - check-sums? - download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip? - #:in-place? #t - #:in-place-clean? #t) - (set! staged? #t))) - (λ () - (when (and use-cache? (not staged?)) - (clean-cache new-url checksum)) - (unless staged? - (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 "Cloning 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) - #f - #:use-cache? use-cache?))))] - [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 checksum - #:use-cache? use-cache? - #:download-printf download-printf)))])) - (define staged? #f) - (dynamic-wind - void - (λ () - (download-package!) - (log-pkg-debug "\tDownloading done, installing ~a as ~a" - package-path pkg-name) - (begin0 - (stage-package/info package-path - download-type - pkg-name - #:given-checksum checksum - #:cached-url pkg-url - #:use-cache? use-cache? - check-sums? - download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip?) - (set! staged? #t))) - (λ () - (when (or (file-exists? package-path) - (directory-exists? package-path)) - (when (and use-cache? (not staged?)) - (clean-cache pkg-url checksum)) - (delete-directory/files package-path))))])) - (define info (update-install-info-orig-pkg downloaded-info - 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 check-sums? - (check-checksum checksum (install-info-checksum info) - "mismatched" - pkg - (and use-cache? cached-url))) - (update-install-info-checksum - info - checksum)] - [(eq? type 'file) - (define pkg-path (if (path? pkg) - pkg - (package-source->path pkg type))) - (unless (file-exists? pkg-path) - (pkg-error "no such file\n path: ~a" pkg-path)) - (define checksum-pth (format "~a.CHECKSUM" pkg-path)) - (define expected-checksum - (and (file-exists? checksum-pth) - check-sums? - (file->string checksum-pth))) - (check-checksum given-checksum expected-checksum "unexpected" pkg-path #f) - (define actual-checksum - (with-input-from-file pkg-path - (λ () - (sha1 (current-input-port))))) - (check-checksum expected-checksum actual-checksum "mismatched" pkg-path - (and use-cache? cached-url)) - (define checksum - actual-checksum) - (define pkg-format (filename-extension pkg-path)) - (define pkg-dir - (make-temporary-file (string-append "~a-" pkg-name) - 'directory)) - (define staged? #f) - (dynamic-wind - void - (λ () - (make-directory* pkg-dir) - - (match pkg-format - [#"tgz" - (untar pkg-path pkg-dir) - (remove-extra-directory-layer pkg-dir)] - [#"tar" - (untar pkg-path pkg-dir) - (remove-extra-directory-layer pkg-dir)] - [#"gz" ; assuming .tar.gz - (untar pkg-path pkg-dir) - (remove-extra-directory-layer pkg-dir)] - [#"zip" - (unzip pkg-path (make-filesystem-entry-reader #:dest pkg-dir) - #:preserve-timestamps? #t - #:utc-timestamps? #t) - (remove-extra-directory-layer pkg-dir)] - [#"plt" - (make-directory* pkg-dir) - (unpack pkg-path pkg-dir - (lambda (x) (log-pkg-debug "~a" x)) - (lambda () pkg-dir) - #f - (lambda (auto-dir main-dir file) pkg-dir)) - (define info-path (build-path pkg-dir "info.rkt")) - (unless (file-exists? info-path) - ;; Add in "info.rkt" file to make it multi-collection, - ;; since a ".plt" archive is never single-collection. This - ;; is needed for supporting old ".plt" archives as packages. - (call-with-output-file info-path - (lambda (o) - (fprintf o "#lang setup/infotab\n") - (write '(define collection 'multi) o) - (newline o))))] - [x - (pkg-error "invalid package format\n given: ~a" x)]) - - (begin0 - (update-install-info-checksum - (update-install-info-orig-pkg - (stage-package/info pkg-dir - 'dir - pkg-name - #:given-checksum checksum - #:cached-url cached-url - #:use-cache? use-cache? - check-sums? - download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip? - #:in-place? (not strip-mode) - #:in-place-clean? #t) - `(file ,(simple-form-path* pkg-path))) - checksum) - (unless strip-mode - (set! staged? #t)))) - (λ () - (unless staged? - (delete-directory/files pkg-dir))))] - [(or (eq? type 'dir) - (eq? type 'link) - (eq? type 'static-link)) - (define pkg-path (if (path? pkg) - pkg - (package-source->path pkg type))) - (unless (directory-exists? pkg-path) - (pkg-error "no such directory\n path: ~a" pkg-path)) - (let ([pkg-path (directory-path-no-slash pkg-path)]) - (cond - [(or (eq? type 'link) - (eq? type 'static-link)) - (install-info pkg-name - `(,type ,(path->string - (find-relative-path (pkg-installed-dir) - (simple-form-path pkg-path) - #:more-than-root? #t))) - pkg-path - #f - given-checksum ; if a checksum is provided, just use it - (directory->module-paths pkg pkg-name metadata-ns) - (directory->additional-installs pkg pkg-name metadata-ns))] - [else - (define pkg-dir - (if in-place? - (if strip-mode - (pkg-error "cannot strip directory in place") - pkg-path) - (let ([pkg-dir (make-temporary-file "pkg~a" 'directory)]) - (delete-directory pkg-dir) - (if strip-mode - (begin - (unless force-strip? - (check-strip-compatible strip-mode pkg-name pkg pkg-error)) - (make-directory* pkg-dir) - (generate-stripped-directory strip-mode pkg pkg-dir)) - (begin - (make-parent-directory* pkg-dir) - (copy-directory/files pkg-path pkg-dir #:keep-modify-seconds? #t))) - pkg-dir))) - (when (or (not in-place?) - in-place-clean?) - (drop-redundant-files pkg-dir)) - (install-info pkg-name - `(dir ,(simple-form-path* pkg-path)) - pkg-dir - (or (not in-place?) in-place-clean?) - given-checksum ; if a checksum is provided, just use it - (directory->module-paths pkg-dir pkg-name metadata-ns) - (directory->additional-installs pkg-dir pkg-name metadata-ns))]))] - [(eq? type 'name) - (define catalog-info (package-catalog-lookup pkg #f download-printf)) - (log-pkg-debug "catalog response: ~s" catalog-info) - (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 - #:use-cache? use-cache? - check-sums? - download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip?)) - (when check-sums? - (check-checksum given-checksum checksum "unexpected" pkg #f) - (check-checksum checksum (install-info-checksum info) "incorrect" pkg #f)) - (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 - #:namespace [metadata-ns (make-metadata-namespace)] - #:in-place? [in-place? #f] - #:strip [strip-mode #f] - #:force-strip? [force-strip? #f] - #:use-cache? [use-cache? #f] - #:quiet? [quiet? #t]) - (define i (stage-package/info (pkg-desc-source desc) - (pkg-desc-type desc) - (pkg-desc-name desc) - #:given-checksum (pkg-desc-checksum desc) - #:use-cache? use-cache? - #t - (if quiet? void printf) - metadata-ns - #:in-place? in-place? - #:strip strip-mode - #:force-strip? force-strip?)) - (values (install-info-name i) - (install-info-directory i) - (install-info-checksum i) - (install-info-clean? i) - (install-info-module-paths i))) - -(define (ask question) - (let loop () - (printf question) - (printf " [Y/n/a/?] ") - (flush-output) - (match (string-trim (read-line (current-input-port) 'any)) - [(or "y" "Y" "") - 'yes] - [(or "n" "N") - 'no] - [(or "a" "A") - 'always-yes] - [x - (eprintf "Invalid answer: ~a\n" x) - (eprintf " Answer nothing or `y' or `Y' for \"yes\", `n' or `N' for \"no\", or\n") - (eprintf " `a' or `A' for \"yes for all\".\n") - (loop)]))) - -(define (format-deps update-deps) - (format-list (for/list ([ud (in-list update-deps)]) - (cond - [(pkg-desc? ud) - (pkg-desc-name ud)] - [(string? ud) - ud] - [else - (format "~a (have ~a, need ~a)" - (car ud) - (caddr ud) - (cadddr ud))])))) - -(define (install-packages - #:old-infos old-infos - #:old-descs old-descs - #:pre-succeed pre-succeed - #:dep-behavior dep-behavior - #:update-deps? update-deps? - #:update-implies? update-implies? - #:update-cache update-cache - #:updating? updating? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:skip-installed? skip-installed? - #:force? force? - #:all-platforms? all-platforms? - #:quiet? quiet? - #:from-command-line? from-command-line? - #:conversation conversation - #:strip strip-mode - #:force-strip? force-strip? - #:link-dirs? link-dirs? - #:local-docs-ok? local-docs-ok? - #:ai-cache ai-cache - descs) - (define download-printf (if quiet? void printf/flush)) - (define check-sums? (not ignore-checksums?)) - (define current-scope-db (read-pkg-db)) - (define all-db (merge-pkg-dbs)) - (define path-pkg-cache (make-hash)) - (define (install-package/outer infos desc info) - (match-define (pkg-desc pkg type orig-name given-checksum auto?) desc) - (match-define - (install-info pkg-name orig-pkg pkg-dir clean? checksum module-paths additional-installs) - info) - (define name? (eq? 'catalog (first orig-pkg))) - (define this-dep-behavior (or dep-behavior - (if name? - 'search-ask - 'fail))) - (define do-update-deps? - (and update-deps? - (member this-dep-behavior '(search-auto search-ask)))) - (define (clean!) - (when clean? - (delete-directory/files pkg-dir))) - (define (show-dependencies deps update? auto?) - (unless quiet? - (printf/flush "The following~a packages are listed as dependencies of ~a~a:~a\n" - (if update? " out-of-date" " uninstalled") - pkg-name - (if (or auto? (eq? conversation 'always-yes)) - (format "\nand they will be ~a~a" - (if auto? "automatically " "") - (if update? "updated" "installed")) - "") - (if update? - (format-deps deps) - (format-list deps))))) - (define simultaneous-installs - (for/hash ([i (in-list infos)]) - (values (install-info-name i) (install-info-directory i)))) - - (when (and (pair? orig-pkg) - (or (eq? (car orig-pkg) 'link) - (eq? (car orig-pkg) 'static-link))) - (disallow-package-path-overlaps pkg-name - pkg-dir - path-pkg-cache - simultaneous-installs)) - (cond - [(and (not updating?) - (hash-ref all-db pkg-name #f) - ;; Already installed, but can force if the install is for - ;; a wider scope: - (not (and (not (hash-ref current-scope-db pkg-name #f)) - force?))) - (define existing-pkg-info (hash-ref all-db pkg-name #f)) - (cond - [(and (pkg-info-auto? existing-pkg-info) - (not (pkg-desc-auto? desc)) - ;; Don't confuse a promotion request with a different-source install: - (equal? (pkg-info-orig-pkg existing-pkg-info) orig-pkg) - ;; Also, make sure it's installed in the scope that we're changing: - (hash-ref current-scope-db pkg-name #f)) - ;; promote an auto-installed package to a normally installed one - (lambda () - (unless quiet? - (download-printf "Promoting ~a from auto-installed to explicitly installed\n" pkg-name)) - (update-pkg-db! pkg-name (update-auto existing-pkg-info #f)))] - [else - ;; Fail --- already installed - (clean!) - (cond - [(not (hash-ref current-scope-db pkg-name #f)) - (pkg-error (~a "package is currently installed in a wider scope\n" - " package: ~a\n" - " installed scope: ~a\n" - " given scope: ~a") - pkg-name - (find-pkg-installation-scope pkg-name #:next? #t) - (current-pkg-scope))] - [(not (equal? (pkg-info-orig-pkg existing-pkg-info) orig-pkg)) - (pkg-error (~a "package is already installed from a different source\n" - " package: ~a\n" - " installed source: ~a\n" - " given source: ~a") - pkg-name - (pkg-info-orig-pkg existing-pkg-info) - orig-pkg)] - [else - (pkg-error "package is already installed\n package: ~a" - pkg-name)])])] - [(and - (not force?) - (for/or ([mp (in-set module-paths)]) - ;; In an installed collection? Try resolving the path: - (define r (with-handlers ([exn:fail:filesystem:missing-module? (lambda (x) #f)]) - ((current-module-name-resolver) mp #f #f #f))) - (define f (and r (resolved-module-path-name r))) - (when f - (unless (path? f) - (pkg-error "expected a filesystem path for a resolved module path: ~a" mp))) - ;; Check for source or compiled: - (cond - [(and f - (or (file-exists? f) - (file-exists? (path-replace-suffix f #".ss")) - (file-exists? (get-compilation-bytecode-file f)) - (file-exists? (get-compilation-bytecode-file (path-replace-suffix f #".ss")))) - (or (not updating?) - (not (equal? pkg-name (path->pkg f #:cache path-pkg-cache))))) - ;; This module is already installed - (cons (path->pkg f #:cache path-pkg-cache) mp)] - [else - ;; Compare with simultaneous installs - (for/or ([other-pkg-info (in-list infos)] - #:unless (eq? other-pkg-info info)) - (and (set-member? (install-info-module-paths other-pkg-info) mp) - (cons (install-info-name other-pkg-info) - mp)))]))) - => - (λ (conflicting-pkg*mp) - (clean!) - (match-define (cons conflicting-pkg mp) conflicting-pkg*mp) - (if conflicting-pkg - (pkg-error (~a "packages ~aconflict\n" - " package: ~a\n" - " package: ~a\n" - " module path: ~s") - (if (equal? conflicting-pkg pkg-name) - "in different scopes " - "") - pkg conflicting-pkg (pretty-module-path mp)) - (pkg-error (~a "package conflicts with existing installed module\n" - " package: ~a\n" - " module path: ~s") - pkg (pretty-module-path mp))))] - [(and - (not force?) - (for/or ([ai (in-set additional-installs)]) - ;; Check for source or compiled: - (cond - ;; If `local-docs-ok?`, exempt doc collisions for user-scope install, since - ;; user-scope documentation is rendered within the package: - [(and local-docs-ok? - (eq? (car ai) 'doc) - (eq? (current-pkg-scope) 'user)) - #f] - [(set-member? (get-additional-installed (car ai) - simultaneous-installs - ai-cache - metadata-ns - path-pkg-cache) - ai) - ;; This item is already installed - (cons #f ai)] - [else - ;; Compare with simultaneous installs - (for/or ([other-pkg-info (in-list infos)] - #:unless (eq? other-pkg-info info)) - (and (set-member? (install-info-additional-installs other-pkg-info) ai) - (cons (install-info-name other-pkg-info) - ai)))]))) - => - (λ (conflicting-pkg*ai) - (clean!) - (match-define (cons conflicting-pkg ai) conflicting-pkg*ai) - (if conflicting-pkg - (pkg-error (~a "packages ~aconflict\n" - " package: ~a\n" - " package: ~a\n" - " item category: ~a\n" - " item name: ~s") - (if (equal? conflicting-pkg pkg-name) - "in different scopes " - "") - pkg conflicting-pkg - (car ai) - (cdr ai)) - (pkg-error (~a "package conflicts with existing installed item\n" - " package: ~a\n" - " item category: ~a\n" - " item name: ~s") - pkg - (car ai) - (cdr ai))))] - [(and - (not (eq? dep-behavior 'force)) - (let () - (define deps (get-all-deps metadata-ns pkg-dir)) - (define unsatisfied-deps - (map dependency->source - (filter-not (λ (dep) - (define name (dependency->name dep)) - (or (equal? name "racket") - (not (or all-platforms? - (dependency-this-platform? dep))) - (hash-ref simultaneous-installs name #f) - (hash-has-key? all-db name))) - deps))) - (and (not (empty? unsatisfied-deps)) - unsatisfied-deps))) - => - (λ (unsatisfied-deps) - (match this-dep-behavior - ['fail - (clean!) - (pkg-error (~a "missing dependencies" - (if from-command-line? - (~a ";\n" - " specify `--deps search-auto' to install them, or\n" - " specify `--deps search-ask' to be asked about installing them") - "") - "\n" - " for package: ~a\n" - " missing packages:~a") - pkg - (format-list unsatisfied-deps))] - ['search-auto - ;; (show-dependencies unsatisfied-deps #f #t) - (raise (vector updating? infos pkg-name unsatisfied-deps void 'always-yes))] - ['search-ask - (show-dependencies unsatisfied-deps #f #f) - (case (if (eq? conversation 'always-yes) - 'always-yes - (ask "Would you like to install these dependencies?")) - [(yes) - (raise (vector updating? infos pkg-name unsatisfied-deps void 'again))] - [(always-yes) - (raise (vector updating? infos pkg-name unsatisfied-deps void 'always-yes))] - [(no) - (clean!) - (pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))])]))] - [(and - (or do-update-deps? - update-implies?) - (let () - (define-values (run-deps build-deps) (get-all-deps* metadata-ns pkg-dir)) - (define deps (append run-deps build-deps)) - (define implies (list->set - (append - (get-all-implies metadata-ns pkg-dir run-deps) - (get-all-update-implies metadata-ns pkg-dir deps)))) - (define update-pkgs - (append-map (λ (dep) - (define name (dependency->name dep)) - (define this-platform? (or all-platforms? - (dependency-this-platform? dep))) - (or (and this-platform? - (or do-update-deps? - (set-member? implies name)) - (not (hash-ref simultaneous-installs name #f)) - ((packages-to-update download-printf current-scope-db - #:must-update? #f - #:deps? do-update-deps? - #:implies? update-implies? - #:update-cache update-cache - #:namespace metadata-ns - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - name)) - null)) - deps)) - (and (not (empty? update-pkgs)) - update-pkgs - (let () - (define (continue conversation) - (raise (vector #t infos pkg-name update-pkgs - (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) update-pkgs)) - conversation))) - (match (if (andmap (lambda (dep) (set-member? implies (pkg-desc-name dep))) - update-pkgs) - 'search-auto - this-dep-behavior) - ['search-auto - (show-dependencies update-pkgs #t #t) - (continue conversation)] - ['search-ask - (show-dependencies update-pkgs #t #f) - (case (if (eq? conversation 'always-yes) - 'always-yes - (ask "Would you like to update these dependencies?")) - [(yes) - (continue 'again)] - [(always-yes) - (continue 'always-yes)] - [(no) - ;; Don't fail --- just skip update - #f])]))))) - (error "internal error: should have raised an exception")] - [(and - (not (eq? dep-behavior 'force)) - (let () - (define deps (get-all-deps metadata-ns pkg-dir)) - (define update-deps - (filter-map (λ (dep) - (define name (dependency->name dep)) - (define req-vers (dependency->version dep)) - (define this-platform? (or all-platforms? - (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))) - ;; 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) - (define db current-scope-db) - (let ([to-update (append-map (packages-to-update download-printf db - #:deps? update-deps? - #:implies? update-implies? - #:update-cache update-cache - #:namespace metadata-ns - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - update-pkgs)]) - (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update)))) - (match this-dep-behavior - ['fail - (clean!) - (report-mismatch update-deps)] - ['search-auto - (show-dependencies update-deps #t #t) - (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'always-yes))] - ['search-ask - (show-dependencies update-deps #t #f) - (case (if (eq? conversation 'always-yes) - 'always-yes - (ask "Would you like to update these dependencies?")) - [(yes) - (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'again))] - [(always-yes) - (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'always-yes))] - [(no) - (clean!) - (report-mismatch update-deps)])]))] - [else - (λ () - (when updating? - (download-printf "Re-installing ~a\n" pkg-name)) - (define final-pkg-dir - (cond - [clean? - (define final-pkg-dir (select-package-directory - (build-path (pkg-installed-dir) pkg-name))) - (make-parent-directory* final-pkg-dir) - (copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t) - (clean!) - final-pkg-dir] - [else - pkg-dir])) - (define single-collect (pkg-single-collection final-pkg-dir - #:name pkg-name - #:namespace post-metadata-ns)) - (log-pkg-debug "creating ~alink to ~e" - (if single-collect "single-collection " "") - final-pkg-dir) - (define scope (current-pkg-scope)) - (links final-pkg-dir - #:name single-collect - #:user? (not (or (eq? 'installation scope) - (path? scope))) - #:file (scope->links-file scope) - #:root? (not single-collect) - #:static-root? (and (pair? orig-pkg) - (eq? 'static-link (car orig-pkg)))) - (define alt-dir-name - ;; If we had to pick an alternate dir name, then record it: - (let-values ([(base name dir?) (split-path final-pkg-dir)]) - (and (regexp-match? #rx"[+]" name) - (path->string name)))) - (define this-pkg-info - (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name)) - (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) - #:given-checksum (pkg-desc-checksum v) - #:use-cache? use-cache? - check-sums? download-printf - metadata-ns - #:strip strip-mode - #:force-strip? force-strip? - #:link-dirs? link-dirs?))) - ;; For the top-level call, we need to double-check that all provided packages - ;; were distinct: - (for/fold ([ht (hash)]) ([i (in-list infos)] - [desc (in-list descs)]) - (define name (install-info-name i)) - (when (hash-ref ht name #f) - (pkg-error (~a "given package sources have the same package name\n" - " package name: ~a\n" - " package source: ~a\n" - " package source: ~a") - name - (pkg-desc-source (hash-ref ht name #f)) - (pkg-desc-source desc))) - (hash-set ht name desc)) - - (define all-descs (append old-descs descs)) - (define all-infos (append old-infos infos)) - - (define do-its - (map (curry install-package/outer all-infos) - all-descs - all-infos)) - (pre-succeed) - - (define post-metadata-ns (make-metadata-namespace)) - (for-each (λ (t) (t)) do-its) - - (define (is-promote? info) - ;; if the package name is in `current-scope-db', we must - ;; be simply promiting the package, and so it's - ;; already set up: - (and (hash-ref current-scope-db (install-info-name info) #f) #t)) - - (define setup-collects - (let ([db (read-pkg-db)]) - (get-setup-collects ((if updating? - (make-close-over-depending (read-pkg-db) - post-metadata-ns - all-platforms?) - values) - (map install-info-name - (if updating? - all-infos - (filter-not is-promote? all-infos)))) - db - post-metadata-ns))) - - (cond - [(or (null? do-its) - (and (not updating?) (andmap is-promote? all-infos))) - ;; No actions, so no setup: - 'skip] - [else - setup-collects])) - -(define (pkg-single-collection dir - #:name [pkg-name (let-values ([(base name dir?) (split-path dir)]) - (path-element->string name))] - #:namespace [metadata-ns (make-metadata-namespace)]) - (define i (get-pkg-info dir metadata-ns)) - (if (not i) - pkg-name - (let ([s (i 'collection (lambda () 'use-pkg-name))]) - (unless (or (collection-name-element? s) - (eq? s 'multi) - (eq? s 'use-pkg-name)) - (log-error (format (~a "bad `collection' definition in \"info.rkt\";\n" - " definition will be ignored\n" - " path: ~a\n" - " found: ~e\n" - " expected: (or/c collection-name-element? 'multi 'use-pkg-name)") - (build-path dir "info.rkt") - s))) - (or (and (collection-name-element? s) - s) - (and (eq? s 'use-pkg-name) - pkg-name))))) - -(define (get-setup-collects pkg-names db metadata-ns) - (maybe-append - (for/list ([pkg-name (in-list pkg-names)]) - (define pkg-dir (pkg-directory* pkg-name #:db db)) - (define single-collect - (and pkg-dir - (pkg-single-collection pkg-dir #:name pkg-name #:namespace metadata-ns))) - (or (and (not pkg-dir) null) - (and single-collect (list single-collect)) - (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 ((make-close-over-depending db metadata-ns all-platforms?) l) - (define setup-pkgs (list->set l)) - (define empty-set (set)) - (define rev-pkg-deps - (for/fold ([rev (hash)]) ([pkg-name (in-hash-keys db)]) - (for/fold ([rev rev]) ([dep (in-list ((package-dependencies metadata-ns db all-platforms?) - pkg-name))]) - (hash-update rev dep (lambda (v) (set-add v pkg-name)) empty-set)))) - (let loop ([check setup-pkgs] [setup-pkgs setup-pkgs]) - ;; Find all packages that depend on a package in `check': - (define new-check - (set-subtract (for/fold ([new-check (set)]) ([pkg (in-set check)]) - (set-union new-check - (hash-ref rev-pkg-deps pkg empty-set))) - setup-pkgs)) - (cond - [(set-empty? new-check) - ;; found fixed point: - (set->list setup-pkgs)] - [else - ;; more packages to setup and check: - (loop new-check - (set-union setup-pkgs new-check))]))) - -(define (select-package-directory dir #:counter [counter 0]) - (define full-dir (if (zero? counter) - dir - (let-values ([(base name dir?) (split-path dir)]) - (define new-name (bytes->path - (bytes-append (path->bytes name) - (string->bytes/utf-8 - (~a "+" counter))))) - (if (path? base) - (build-path base new-name) - new-name)))) - (cond - [(directory-exists? full-dir) - ;; If the directory exists, assume that we'd like to replace it. - ;; Maybe the directory couldn't be deleted when a package was - ;; uninstalled, and maybe it will work now (because some process - ;; has completed on Windows or some other filesystem with locks). - (with-handlers ([exn:fail:filesystem? - (lambda (exn) - (log-pkg-warning "error deleting old directory: ~a" - (exn-message exn)) - (select-package-directory dir #:counter (add1 counter)))]) - (delete-directory/files full-dir) - ;; delete succeeded: - full-dir)] - [else - ;; all clear to use the selected name: - full-dir])) - -(define (snoc l x) - (append l (list x))) - -(define (pkg-install descs - #:old-infos [old-infos empty] - #:old-auto+pkgs [old-descs empty] - #:all-platforms? [all-platforms? #f] - #:force? [force #f] - #:ignore-checksums? [ignore-checksums? #f] - #:strict-doc-conflicts? [strict-doc-conflicts? #f] - #:use-cache? [use-cache? #t] - #:skip-installed? [skip-installed? #f] - #:pre-succeed [pre-succeed void] - #:dep-behavior [dep-behavior #f] - #:update-deps? [update-deps? #f] - #:update-implies? [update-implies? #t] - #:update-cache [update-cache (make-hash)] - #:updating? [updating? #f] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f] - #:conversation [conversation #f] - #:strip [strip-mode #f] - #:force-strip? [force-strip? #f] - #:link-dirs? [link-dirs? #f] - #:summary-deps [summary-deps empty]) - (define new-descs - (remove-duplicates - (if (not skip-installed?) - descs - (let ([db (read-pkg-db)]) - (filter (lambda (d) - (define pkg-name - (or (pkg-desc-name d) - (package-source->name (pkg-desc-source d) - (pkg-desc-type d)))) - (define i (hash-ref db pkg-name #f)) - (or (not i) (pkg-info-auto? i))) - descs))) - pkg-desc=?)) - (with-handlers* ([vector? - (match-lambda - [(vector updating? new-infos dep-pkg deps more-pre-succeed conv) - (pkg-install - #:summary-deps (snoc summary-deps (vector dep-pkg deps)) - #:old-infos new-infos - #:old-auto+pkgs (append old-descs new-descs) - #:all-platforms? all-platforms? - #:force? force - #:ignore-checksums? ignore-checksums? - #:strict-doc-conflicts? strict-doc-conflicts? - #:use-cache? use-cache? - #:dep-behavior dep-behavior - #:update-deps? update-deps? - #:update-implies? update-implies? - #:update-cache update-cache - #:pre-succeed (lambda () (pre-succeed) (more-pre-succeed)) - #:updating? updating? - #:conversation conv - #:strip strip-mode - #:force-strip? force-strip? - (for/list ([dep (in-list deps)]) - (if (pkg-desc? dep) - dep - (pkg-desc dep #f #f #f #t))))])]) - (begin0 - (install-packages - #:old-infos old-infos - #:old-descs old-descs - #:all-platforms? all-platforms? - #:force? force - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:skip-installed? skip-installed? - #:dep-behavior dep-behavior - #:update-deps? update-deps? - #:update-implies? update-implies? - #:update-cache update-cache - #:pre-succeed pre-succeed - #:updating? updating? - #:quiet? quiet? - #:from-command-line? from-command-line? - #:conversation conversation - #:strip strip-mode - #:force-strip? force-strip? - #:link-dirs? link-dirs? - #:local-docs-ok? (not strict-doc-conflicts?) - #:ai-cache (box #f) - new-descs) - (unless (empty? summary-deps) - (unless quiet? - (printf/flush "The following~a packages were listed as dependencies~a:~a\n" - (if updating? " out-of-date" " uninstalled") - (format "\nand they were ~a~a" - (if (eq? dep-behavior 'search-auto) "automatically " "") - (if updating? "updated" "installed")) - (string-append* - (for/list ([p*ds (in-list summary-deps)]) - (match-define (vector n ds) p*ds) - (format "\n dependencies of ~a:~a" - n - (if updating? - (format-deps ds) - (format-list ds))))))))))) - -;; Determine packages to update, starting with `pkg-name'. If `pkg-name' -;; needs to be updated, return it in a list. Otherwise, if `deps?', -;; then return a list of dependencies that need to be updated. -;; (If a package needs to be updated, wait until the update -;; has been inspected for further dependencies.) -;; If `must-installed?', then complain if the package is not -;; installed inthe current scope. -;; If `must-update?', then complain if the package is not -;; updatable. -;; The `update-cache' argument is used to cache which packages -;; are already being updated and downloaded checksums. -(define ((packages-to-update download-printf db - #:must-installed? [must-installed? #t] - #:must-update? [must-update? #t] - #:deps? deps? - #:implies? implies? - #:namespace metadata-ns - #:update-cache update-cache - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - pkg-name) - (cond - [(pkg-desc? pkg-name) - ;; Infer the package-source type and name: - (define-values (inferred-name type) (package-source->name+type - (pkg-desc-source pkg-name) - (pkg-desc-type pkg-name) - #:must-infer-name? (not (pkg-desc-name pkg-name)) - #:complain complain-about-source)) - (define name (or (pkg-desc-name pkg-name) - inferred-name)) - ;; Check that the package is installed, and get current checksum: - (define info (package-info name #:db db)) - (define new-checksum (checksum-for-pkg-source (pkg-desc-source pkg-name) - type - name - (pkg-desc-checksum pkg-name) - download-printf)) - (unless (or ignore-checksums? (not (pkg-desc-checksum pkg-name))) - (unless (equal? (pkg-desc-checksum pkg-name) new-checksum) - (pkg-error (~a "incorrect checksum on package\n" - " package source: ~a\n" - " expected: ~e\n" - " got: ~e") - (pkg-desc-source pkg-name) - (pkg-desc-checksum pkg-name) - new-checksum))) - (if (or (not (equal? (pkg-info-checksum info) - new-checksum)) - ;; No checksum available => always update - (not new-checksum)) - ;; Update: - (begin - (hash-set! update-cache (pkg-desc-source pkg-name) #t) - (list (pkg-desc (pkg-desc-source pkg-name) - (pkg-desc-type pkg-name) - name - (pkg-desc-checksum pkg-name) - (pkg-desc-auto? pkg-name)))) - ;; No update needed, but maybe check dependencies: - (if (or deps? - implies?) - ((packages-to-update download-printf db - #:must-update? #f - #:deps? deps? - #:implies? implies? - #:update-cache update-cache - #:namespace metadata-ns - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - name) - null))] - [(eq? #t (hash-ref update-cache pkg-name #f)) - ;; package is already being updated - null] - ;; A string indicates that package source that should be - ;; looked up in the installed packages to get the old source - ;; for getting the checksum: - [(package-info pkg-name #:db db must-update?) - => - (lambda (m) - (match-define (pkg-info orig-pkg checksum auto?) m) - (match orig-pkg - [`(,(or 'link 'static-link) ,orig-pkg-dir) - (if must-update? - (pkg-error (~a "cannot update linked packages~a\n" - " package name: ~a\n" - " package source: ~a") - (if from-command-line? - " without `--link'" - " without new link") - pkg-name - (normalize-path - (path->complete-path orig-pkg-dir (pkg-installed-dir)))) - null)] - [`(dir ,_) - (if must-update? - (pkg-error (~a "cannot update packages installed locally;\n" - " package was installed via a local directory\n" - " package name: ~a") - pkg-name) - null)] - [`(file ,_) - (if must-update? - (pkg-error (~a "cannot update packages installed locally;\n" - " package was installed via a local file\n" - " package name: ~a") - pkg-name) - null)] - [`(,_ ,orig-pkg-source) - (define new-checksum - (or (hash-ref update-cache pkg-name #f) - (remote-package-checksum orig-pkg download-printf pkg-name))) - ;; Record downloaded checksum: - (hash-set! update-cache pkg-name new-checksum) - (or (and new-checksum - (not (equal? checksum new-checksum)) - (begin - ;; Update it: - (hash-set! update-cache pkg-name #t) - ;; Flush cache of downloaded checksums, in case - ;; there was a race between our checkig and updates on - ;; the catalog server: - (clear-checksums-in-cache! update-cache) - ;; FIXME: the type shouldn't be #f here; it should be - ;; preseved from install time: - (list (pkg-desc orig-pkg-source #f pkg-name #f auto?)))) - (if (or deps? implies?) - ;; Check dependencies - (append-map - (packages-to-update download-printf db - #:must-update? #f - #:deps? deps? - #:implies? implies? - #:update-cache update-cache - #:namespace metadata-ns - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - ((package-dependencies metadata-ns db all-platforms? - #:only-implies? (not deps?)) - pkg-name)) - null))]))] - [else null])) - -(define (clear-checksums-in-cache! update-cache) - (define l (for/list ([(k v) (in-hash update-cache)] - #:when (string? v)) - k)) - (for ([k (in-list l)]) (hash-remove! update-cache k))) - - -(define ((package-dependencies metadata-ns db all-platforms? - #:only-implies? [only-implies? #f]) - pkg-name) - (define pkg-dir (pkg-directory* pkg-name #:db db)) - (define deps - (map dependency->name - (let ([l (get-all-deps metadata-ns pkg-dir)]) - (if all-platforms? - l - (filter dependency-this-platform? l))))) - (if only-implies? - (let ([implies (list->set (get-all-implies metadata-ns pkg-dir deps))]) - (filter (lambda (dep) - (set-member? implies dep)) - deps)) - deps)) - -(define (pkg-update in-pkgs - #:all? [all? #f] - #:dep-behavior [dep-behavior #f] - #:all-platforms? [all-platforms? #f] - #:force? [force? #f] - #:ignore-checksums? [ignore-checksums? #f] - #:strict-doc-conflicts? [strict-doc-conflicts? #f] - #:use-cache? [use-cache? #t] - #:update-deps? [update-deps? #f] - #:update-implies? [update-implies? #t] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f] - #:strip [strip-mode #f] - #:force-strip? [force-strip? #f] - #:link-dirs? [link-dirs? #f]) - (define download-printf (if quiet? void printf)) - (define metadata-ns (make-metadata-namespace)) - (define db (read-pkg-db)) - (define all-mode? (and all? (empty? in-pkgs))) - (define pkgs (cond - [all-mode? (hash-keys db)] - [else in-pkgs])) - (define update-cache (make-hash)) - (define to-update (append-map (packages-to-update download-printf db - #:must-update? (not all-mode?) - #:deps? (or update-deps? - all-mode?) ; avoid races - #:implies? update-implies? - #:update-cache update-cache - #:namespace metadata-ns - #:all-platforms? all-platforms? - #:ignore-checksums? ignore-checksums? - #:use-cache? use-cache? - #:from-command-line? from-command-line?) - pkgs)) - (cond - [(empty? pkgs) - (unless quiet? - (printf/flush (~a "No packages given to update" - (if from-command-line? - ";\n use `--all' to update all packages" - "") - "\n"))) - 'skip] - [(empty? to-update) - (unless quiet? - (printf/flush "No updates available\n")) - 'skip] - [else - (unless quiet? - (printf "Updating:\n") - (for ([u (in-list to-update)]) - (printf " ~a\n" (pkg-desc-name u))) - (flush-output)) - (pkg-install - #:updating? #t - #:pre-succeed (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update)) - #:dep-behavior dep-behavior - #:update-deps? update-deps? - #:update-implies? update-implies? - #:update-cache update-cache - #:quiet? quiet? - #:from-command-line? from-command-line? - #:strip strip-mode - #:force-strip? force-strip? - #:all-platforms? all-platforms? - #:force? force? - #:ignore-checksums? ignore-checksums? - #:strict-doc-conflicts? strict-doc-conflicts? - #:use-cache? use-cache? - #:link-dirs? link-dirs? - to-update)])) - -(define (pkg-show indent - #:directory? [dir? #f] - #:auto? [show-auto? #f]) - (let () - (define db (read-pkg-db)) - (define pkgs (sort (hash-keys db) string-ci<=?)) - (if (null? pkgs) - (printf " [none]\n") - (begin - (table-display - (list* - (append - (list (format "~aPackage~a" - indent - (if show-auto? "[*=auto]" "")) - "Checksum" - "Source") - (if dir? - (list "Directory") - empty)) - (for/list ([pkg (in-list pkgs)] - #:when (or show-auto? - (not (pkg-info-auto? (hash-ref db pkg))))) - (match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg)) - (append - (list (format "~a~a~a" - indent - pkg - (if auto? "*" "")) - (format "~a" checksum) - (format "~a" orig-pkg)) - (if dir? - (list (~a (pkg-directory* pkg #:db db))) - empty))))) - (unless show-auto? - (define n (for/sum ([pkg (in-list pkgs)] - #:when (pkg-info-auto? (hash-ref db pkg))) - 1)) - (unless (zero? n) - (printf "~a[~a auto-installed package~a not shown]\n" - indent - n - (if (= n 1) "" "s")))))))) - -(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-migrate from-version - #:all-platforms? [all-platforms? #f] - #:force? [force? #f] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f] - #:ignore-checksums? [ignore-checksums? #f] - #:strict-doc-conflicts? [strict-doc-conflicts? #f] - #:use-cache? [use-cache? #t] - #:dep-behavior [dep-behavior #f] - #:strip [strip-mode #f] - #:force-strip? [force-strip? #f]) - (define from-db - (parameterize ([current-pkg-scope-version from-version]) - (installed-pkg-table #:scope 'user))) - (define to-install - (sort - (for/list ([(name info) (in-hash from-db)] - #:unless (pkg-info-auto? info)) - (define-values (source type) - (match (pkg-info-orig-pkg info) - [(list 'catalog name) (values name 'name)] - [(list 'url url) (values url #f)] - [(list 'link path) (values path 'link)] - [(list 'static-link path) (values path 'static-link)])) - (pkg-desc source type name #f #f)) - stringsymbol key) (if (complete-path? val) - val - (path->string - (path->complete-path val))))] - [(list (and key (or "download-cache-max-files" - "download-cache-max-bytes")) - val) - (unless (real? (string->number val)) - (pkg-error (~a "invalid value for config key\n" - " config key: ~a\n" - " given value: ~a\n" - " valid values: real numbers") - key - val)) - (update-pkg-cfg! (string->symbol key) (string->number val))] - [(list (and key "doc-open-url") val) - (unless (eq? 'installation (current-pkg-scope)) - (pkg-error (~a "setting `doc-open-url' works only in `installation' scope\n" - " current package scope: ~a") - (current-pkg-scope))) - (update-pkg-cfg! 'doc-open-url (if (equal? val "") #f val))] - [(list* key args) - (pkg-error "unsupported config key\n key: ~a" key)])] - [else - (define (show key+vals indent) - (match key+vals - [(list key) - (match key - ["catalogs" - (for ([s (in-list (read-pkg-cfg/def 'catalogs))]) - (printf "~a~a\n" indent s))] - ["default-scope" - (printf "~a~a\n" indent (read-pkg-cfg/def 'default-scope))] - ["name" - (printf "~a~a\n" indent (read-pkg-cfg/def 'installation-name))] - [(or "download-cache-dir" - "download-cache-max-files" - "download-cache-max-bytes") - (printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))] - ["doc-open-url" - (printf "~a~a\n" indent (or (read-pkg-cfg/def 'doc-open-url) ""))] - [_ - (pkg-error "unsupported config key\n key: ~e" key)])] - [(list) - (pkg-error "config key not provided")] - [_ - (pkg-error (~a "multiple config keys provided" - (if from-command-line? - ";\n supply `--set' to set a config key's value" - "")))])) - (match key+vals - [(list) - (for ([key (in-list '("name" - "catalogs" - "default-scope" - "download-cache-dir" - "download-cache-max-files" - "download-cache-max-bytes"))]) - (printf "~a:\n" key) - (show (list key) " "))] - [_ (show key+vals "")])])) - -(define (create-as-is create:format pkg-name dir orig-dir - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f] - #:hide-src? [hide-src? #f] - #:dest [dest-dir #f]) - (begin - (unless (directory-exists? dir) - (pkg-error "directory does not exist\n path: ~a" dir)) - (match create:format - ['MANIFEST - (unless quiet? - (printf/flush "creating manifest for ~a\n" - orig-dir)) - (with-output-to-file (build-path (or dest-dir 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" pkg-name create:format)) - (define actual-dest-dir (if dest-dir - (path->complete-path dest-dir) - (let-values ([(base name dir?) (split-path dir)]) - (cond - [(path? base) (path->complete-path base)] - [else (current-directory)])))) - (define pkg/complete (path->complete-path pkg actual-dest-dir)) - ;; To make checksums more consistent, set a directory's timestamp to - ;; the latest time of any of its source files. - (define (use-real-timestamp? p) - (and (file-exists? p) - (regexp-match? #rx"[.](?:rkt|ss|scrbl|txt)$" p))) - (define latest-timestamp - (for/fold ([ts #f]) ([f (in-directory dir)]) - (define fts (and (use-real-timestamp? f) - (file-or-directory-modify-seconds f))) - (if (and fts (or (not ts) (fts . > . ts))) - fts - ts))) - (define (file-or-directory-timestamp p) - (or (and (not (use-real-timestamp? p)) - latest-timestamp) - (file-or-directory-modify-seconds p))) - (unless quiet? - (printf/flush "packing~a into ~a\n" - (if hide-src? "" (format " ~a" dir)) - (if dest-dir - pkg/complete - pkg))) - (define (add-directory-layer? content) - ;; We need to add a layer for zip/tgz if the package content - ;; is a single directory, which is an unlikely case. - ;; That mode is not compatble with Racket v60.0.1.12 and earlier. - ;; When only Racket v6.0.1.12 is later is relevant, - ;; we might prefer to always add a layer for consistency and - ;; because it's nicer for manual unpacking. - (and (= 1 (length content)) - (directory-exists? (car content)))) - (match create:format - ['tgz - (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))]) - (define content (directory-list)) - (apply tar-gzip pkg/complete content - #:path-prefix (and (add-directory-layer? content) - pkg-name) - #:get-timestamp file-or-directory-timestamp)))] - ['zip - (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))]) - (define content (directory-list)) - (apply zip pkg/complete content - #:path-prefix (and (add-directory-layer? content) - pkg-name) - #:get-timestamp file-or-directory-timestamp - #:utc-timestamps? #t - #:round-timestamps-down? #t)))] - ['plt - (define dest pkg/complete) - (when (pkg-single-collection #:name pkg-name dir) - (pkg-error (~a "single-collection package not supported in .plt format\n" - " directory: ~a") - dir)) - (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)) - (define chk/complete (path->complete-path chk actual-dest-dir)) - (unless quiet? - (printf/flush "writing package checksum to ~a\n" - (if dest-dir - chk/complete - chk))) - (with-output-to-file chk/complete - #:exists 'replace - (λ () (display (call-with-input-file pkg/complete sha1))))]))) - -(define (stripped-create mode name dir - #:format [create:format 'zip] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f] - #:dest [archive-dest-dir #f]) - (define tmp-dir (make-temporary-file "create-binary-~a" 'directory)) - (dynamic-wind - void - (lambda () - (define dest-dir (build-path tmp-dir name)) - (make-directory dest-dir) - (generate-stripped-directory mode dir dest-dir) - (create-as-is create:format name dest-dir dir - #:hide-src? #t - #:quiet? quiet? - #:from-command-line? from-command-line? - #:dest (if archive-dest-dir - (path->complete-path archive-dest-dir) - (current-directory)))) - (lambda () - (delete-directory/files tmp-dir)))) - -(define (pkg-create create:format dir-or-name - #:pkg-name [given-pkg-name #f] - #:dest [dest-dir #f] - #:source [source 'dir] - #:mode [mode 'as-is] - #:quiet? [quiet? #f] - #:from-command-line? [from-command-line? #f]) - (define pkg-name - (or given-pkg-name - (if (eq? source 'dir) - (path->string (let-values ([(base name dir?) (split-path dir-or-name)]) - name)) - dir-or-name))) - (define dir - (if (eq? source 'dir) - dir-or-name - (let () - (define (get-dir scope) - (parameterize ([current-pkg-scope scope]) - (with-pkg-lock/read-only - (pkg-directory* dir-or-name)))) - (define dir (get-dir 'user)) - (unless dir - (pkg-error (~a "package not installed in user scope\n" - " package name: ~a" - (if (get-dir 'installation) - "\n installed in scope: installation" - "")) - dir-or-name)) - dir))) - (case mode - [(as-is) - (create-as-is create:format pkg-name dir dir - #:dest dest-dir - #:quiet? quiet? - #:from-command-line? from-command-line?)] - [else (stripped-create mode pkg-name dir - #:dest dest-dir - #:format create:format - #:quiet? quiet? - #:from-command-line? from-command-line?)])) - -(define (src->url-or-path src) - (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 a catalog\n" - " URL: ~a") - src)] - [else (path->complete-path src)])) - -(define (url-or-path->url-string p) - (url->string (if (url? p) - p - (path->url p)))) - -(define (pkg-catalog-copy srcs dest - #:from-config? [from-config? #f] - #:merge? [merge? #f] - #:force? [force? #f] - #:override? [override? #f] - #:relative-sources? [relative-sources? #f]) - (define src-paths - (for/list ([src (in-list (append srcs - (if from-config? - (pkg-config-catalogs) - null)))]) - (define src-path (src->url-or-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)])) - - (define dest-dir - (and relative-sources? - (if (db-path? dest-path) - (let-values ([(base name dir?) (split-path dest-path)]) - base) - dest-path))) - - (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 absolute-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)))) - (define details - (if relative-sources? - (for/hash ([(k ht) (in-hash absolute-details)]) - (values k (source->relative-source dest-dir ht))) - absolute-details)) - - (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) - (define vers-details - (for/hash ([(k v) (in-hash details)]) - (values k (select-info-version v)))) - (parameterize ([db:current-pkg-catalog-file dest-path]) - (db:set-catalogs! '("local")) - (db:set-pkgs! "local" - (for/list ([(k v) (in-hash vers-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 vers-details)]) - (define t (hash-ref v 'tags '())) - (unless (null? t) - (db:set-pkg-tags! k "local" t))) - (for ([(k v) (in-hash vers-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 vers-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? - (sort (hash-keys all-details) stringstring 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 (pretty-module-path mod)) - (define mod-str (~a " " (~s pretty-mod))) - (define new-col (if ((+ col (string-length mod-str)) . > . 72) - (begin - (printf "\n ") - 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) stringstring i) - (call-with-input-file* (build-path pkg-path i) - read)))])))) - (unless one-ht - (pkg-error (~a "could not read package catalog\n" - " catalog: ~a") - (url->string i))) - (for/fold ([ht ht]) ([(k v) (in-hash one-ht)]) - (if (hash-ref ht k #f) - ht - (hash-set ht k (source->absolute-source i v)))))) - -(define (extract-pkg-dependencies get-info - #:build-deps? [build-deps? #t] - #:filter? [filter? #f] - #:versions? [versions? #f]) - (define v (if get-info - (get-info 'deps (lambda () empty)) - empty)) - ((check-dependencies 'deps) v) - (define v2 (if (and get-info build-deps?) - (get-info 'build-deps (lambda () empty)) - empty)) - ((check-dependencies 'build-deps) v2) - (define all-v (append v v2)) - (if filter? - (for/list ([dep (in-list all-v)] - #:when (dependency-this-platform? dep)) - (define name - (if (pair? dep) - (car dep) - dep)) - (if versions? - (list name (dependency->version dep)) - name)) - all-v)) - -(define (get-pkg-content desc - #:namespace [metadata-ns (make-metadata-namespace)] - #:extract-info [extract-info extract-pkg-dependencies]) - (define-values (pkg-name dir cksum clean? module-paths) - (pkg-stage desc #:in-place? #t #:namespace metadata-ns)) - (define get-info (get-info/full dir #:namespace metadata-ns)) - (begin0 - (values cksum - (set->list module-paths) - (extract-info get-info)) - (when clean? - (delete-directory/files dir)))) - -(define (pkg-directory->module-paths dir pkg-name - #:namespace [metadata-ns (make-metadata-namespace)]) - (set->list (directory->module-paths dir pkg-name metadata-ns))) - -(define (directory->module-paths dir pkg-name metadata-ns) - (define dummy (build-path dir "dummy.rkt")) - (define compiled (string->path-element "compiled")) - (define single-collect (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns)) - (define (try-path s f) - (define mp - `(lib ,(apply ~a - #:separator "/" - (let ([l (map path-element->string - (explode-path f))]) - (if single-collect - (if (eq? 'relative (car l)) - (cons single-collect (cdr l)) - (cons single-collect l)) - l))))) - (if (module-path? mp) - (set-add s (collapse-module-path mp dummy)) - s)) - (parameterize ([current-directory dir]) - (let loop ([s (set)] [f 'init] [check-zo? #f]) - (cond - [(eq? f 'init) - (for/fold ([s s]) ([f (directory-list)]) - (loop s f check-zo?))] - [(directory-exists? f) - ;; Count ".zo" files toward the set of module paths only - ;; if an "info.rkt" in an enclosing directory says to - ;; assume virtual sources. Otherwise, the ".zo" file will - ;; be discarded by `raco setup'. - (define sub-check-zo? - (or check-zo? - (let ([i (get-pkg-info f metadata-ns)]) - (and i - (i 'assume-virtual-sources (lambda () #f)))))) - (for/fold ([s s]) ([f (directory-list f #:build? #t)]) - (loop s f sub-check-zo?))] - [(not (file-exists? f)) s] - [else - (define-values (base name dir?) (split-path f)) - (cond - [(and (eq? 'relative base) (not single-collect)) s] - [else - (define bstr (path-element->bytes name)) - (cond - [(or (equal? #"info.rkt" bstr) - (equal? #"info.ss" bstr)) - ;; don't count "info.rkt" as a conflict, because - ;; splices may need their own "info.rkt"s, and - ;; `raco setup' can handle that - s] - [(regexp-match? #rx#"[.](?:rkt|ss|scrbl)$" bstr) - (try-path s f)] - [(and check-zo? - (regexp-match? #rx#"_(?:rkt|ss|scrbl)[.]zo$" (path-element->bytes name))) - (define-values (dir-base dir-name dir?) (split-path base)) - (cond - [(eq? 'relative dir-base) s] - [(equal? dir-name compiled) - (define bstr2 (regexp-replace - #rx#"_(?:rkt|ss|scrbl)[.]zo$" - (path-element->bytes name) - #".rkt")) - (if (equal? #"info.rkt" bstr2) - s - (try-path s (build-path dir-base - (bytes->path-element - bstr2))))] - [else s])] - [else s])])])))) - -(define (pkg-directory->additional-installs dir pkg-name - #:namespace [metadata-ns (make-metadata-namespace)] - #:system-type [sys-type #f] - #:system-library-subpath [sys-lib-subpath #f]) - (set->list (directory->additional-installs dir pkg-name metadata-ns - #:system-type sys-type - #:system-library-subpath sys-lib-subpath))) - -(define (directory->additional-installs dir pkg-name metadata-ns - #:system-type [sys-type #f] - #:system-library-subpath [sys-lib-subpath #f]) - (define single-collect - (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns)) - (let loop ([s (set)] [f dir] [top? #t] [omits (set)]) - (cond - [(and (directory-exists? f) - (not (set-member? omits (simplify-path f)))) - (define i (get-pkg-info f metadata-ns)) - (define omit-paths (if i - (i 'compile-omit-paths (lambda () null)) - null)) - (cond - [(eq? omit-paths 'all) - s] - [else - (define omit-files (if i - (i 'compile-omit-files (lambda () null)) - null)) - (define new-s - (if (and i (or single-collect (not top?))) - (set-union (extract-additional-installs i sys-type sys-lib-subpath) - s) - s)) - (define new-omits - (set-union - omits - (for/set ([i (in-list (append omit-paths omit-files))]) - (simplify-path (build-path f i))))) - (for/fold ([s new-s]) ([f (directory-list f #:build? #t)]) - (loop s f #f new-omits))])] - [else s]))) - -(define (extract-additional-installs i sys-type sys-lib-subpath) - (define (extract-documents i) - (let ([s (i 'scribblings (lambda () null))]) - (for/set ([doc (in-list (if (list? s) s null))] - #:when (and (list? doc) - (pair? doc) - (path-string? (car doc)) - (or ((length doc) . < . 2) - (list? (cadr doc))) - (or ((length doc) . < . 4) - (collection-name-element? (list-ref doc 3))))) - (define flags (if ((length doc) . < . 2) - null - (cadr doc))) - (cond - [(member 'main-doc-root flags) '(main-doc-root . "root")] - [(member 'user-doc-root flags) '(user-doc-root . "root")] - [else - (cons 'doc - (string-foldcase - (if ((length doc) . < . 4) - (let-values ([(base name dir?) (split-path (car doc))]) - (path->string (path-replace-suffix name #""))) - (list-ref doc 3))))])))) - (define (extract-paths i tag keys) - (define (get k) - (define l (i k (lambda () null))) - (if (and (list? l) (andmap path-string? l)) - l - null)) - (list->set (map (lambda (v) (cons tag - (let-values ([(base name dir?) (split-path v)]) - ;; Normalize case, because some platforms - ;; have case-insensitive filesystems: - (string-foldcase (path->string name))))) - (apply - append - (for/list ([k (in-list keys)]) - (get k)))))) - (define (extract-launchers i) - (extract-paths i 'exe '(racket-launcher-names - mzscheme-launcher-names - gracket-launcher-names - mred-launcher-names))) - (define (extract-foreign-libs i) - (extract-paths i 'lib '(copy-foreign-libs - move-foreign-libs))) - (define (extract-shared-files i) - (extract-paths i 'share '(copy-shared-files - move-shared-files))) - (define (extract-man-pages i) - (extract-paths i 'man '(copy-man-pages - move-man-pages))) - (define (this-platform? i) - (define v (i 'install-platform (lambda () #rx""))) - (or (not (platform-spec? v)) - (matching-platform? v - #:system-type sys-type - #:system-library-subpath sys-lib-subpath))) - (set-union (extract-documents i) - (extract-launchers i) - (if (this-platform? i) - (set-union - (extract-foreign-libs i) - (extract-shared-files i) - (extract-man-pages i)) - (set)))) - -(define (get-additional-installed kind skip-ht-keys ai-cache metadata-ns path-pkg-cache) - (or (unbox ai-cache) - (let () - (define skip-pkgs (list->set (hash-keys skip-ht-keys))) - (define dirs (find-relevant-directories '(scribblings - racket-launcher-names - mzscheme-launcher-names - gracket-launcher-names - mred-launcher-names - copy-foreign-libs - move-foreign-libs - copy-shared-files - move-shared-files - copy-man-pages - move-man-pages) - (if (eq? 'user (current-pkg-scope)) - 'all-available - 'no-user))) - (define s (for/fold ([s (set)]) ([dir (in-list dirs)]) - (cond - [(set-member? skip-pkgs (path->pkg dir #:cache path-pkg-cache)) - s] - [else - (define i (get-pkg-info dir metadata-ns)) - (if i - (set-union s (extract-additional-installs i #f #f)) - s)]))) - (set-box! ai-cache s) - s))) - -(define (pkg-catalog-update-local #:catalogs [catalogs (pkg-config-catalogs)] - #:set-catalogs? [set-catalogs? #t] - #:catalog-file [catalog-file (db:current-pkg-catalog-file)] - #:quiet? [quiet? #f] - #:consult-packages? [consult-packages? #f] - #:skip-download-failures? [skip-download-failures? #f]) - (parameterize ([db:current-pkg-catalog-file catalog-file]) - (define current-catalogs (db:get-catalogs)) - (cond - [set-catalogs? - (unless (equal? catalogs current-catalogs) - (db:set-catalogs! catalogs))] - [else - (unless (for/and ([catalog (in-list catalogs)]) - (member catalog current-catalogs)) - (error 'pkg-catalog-update-local - (~a "given catalog list is not a superset of recorded catalogs\n" - " given: ~s\n" - " recorded: ~s") - catalogs - current-catalogs))]) - - (for ([catalog (in-list catalogs)]) - (unless quiet? - (printf/flush "Updating from ~a\n" catalog)) - (parameterize ([current-pkg-catalogs (list (string->url catalog))]) - (define details (for/hash ([(name ht) (get-all-pkg-details-from-catalogs)]) - (values name (select-info-version ht)))) - ;; 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 tags (hash-ref ht 'tags #f)) - (when tags - (db:set-pkg-tags! name catalog tags)) - (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/flush "Downloading ~s\n" source)) - (define-values (checksum modules deps) - (get-pkg-content (pkg-desc source - #f - name - (hash-ref ht 'checksum #f) - #f))) - (db:set-pkg-modules! name catalog checksum modules) - (db:set-pkg-dependencies! name catalog checksum deps))))))) - -(define (pkg-catalog-archive dest-dir - src-catalogs - #:from-config? [from-config? #f] - #:state-catalog [state-catalog #f] - #:relative-sources? [relative-sources? #f] - #:quiet? [quiet? #f] - #:package-exn-handler [package-exn-handler (lambda (name exn) (raise exn))]) - (when (and state-catalog - (not (db-path? (if (path? state-catalog) - state-catalog - (string->path state-catalog))))) - (pkg-error (~a "bad state file path\n" - " given: ~a\n" - " expected: path with \".sqlite\" extension") - state-catalog)) - ;; Take a snapshot of the source catalog: - (define temp-catalog-file (make-temporary-file "pkg~a.sqlite")) - (pkg-catalog-copy (map url-or-path->url-string - (map src->url-or-path src-catalogs)) - temp-catalog-file - #:force? #t ; replaces temporary file - #:from-config? from-config?) - (define pkgs - (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) - (db:get-pkgs))) - ;; Reset state catalog to new packages: - (when state-catalog - (parameterize ([db:current-pkg-catalog-file state-catalog]) - (db:set-catalogs! '("local")) - (db:set-pkgs! "local" (map db:pkg-name pkgs)))) - ;; Remove any package not in `pkgs`: - (define pkgs-dir (build-path dest-dir "pkgs")) - (when (directory-exists? pkgs-dir) - (define keep-pkgs (list->set (map db:pkg-name pkgs))) - (for ([f (in-list (directory-list pkgs-dir))]) - (cond - [(regexp-match #rx"^(.*)[.]zip(?:[.]CHECKSUM)?$" f) - => (lambda (m) - (unless (set-member? keep-pkgs (cadr m)) - (unless quiet? - (printf/flush "Removing old package file ~a\n" f)) - (delete-file (build-path pkgs-dir f))))]))) - ;; Check on each new package: - (for ([pkg (in-list (sort pkgs stringstring pkg-checksum-file) - (call-with-input-file* pkg-file sha1))) - (unless quiet? - (printf/flush "== Archiving ~a ==\nchecksum: ~a\n" (db:pkg-name pkg) (db:pkg-checksum pkg))) - ;; Download/unpack existing package: - (define-values (staged-name staged-dir staged-checksum clean? staged-mods) - (pkg-stage - (pkg-desc (db:pkg-source pkg) #f (db:pkg-name pkg) (db:pkg-checksum pkg) #f) - #:in-place? #t - #:use-cache? #t - #:quiet? quiet?)) - (make-directory* (build-path dest-dir "pkgs")) - ;; Repack: - (pkg-create 'zip - staged-dir - #:pkg-name name - #:dest (build-path dest-dir "pkgs") - #:quiet? quiet?) - (when clean? (delete-directory/files staged-dir)) - ;; Record packed result: - (when state-catalog - (parameterize ([db:current-pkg-catalog-file state-catalog]) - (db:set-pkg! name "local" - (db:pkg-author pkg) - (db:pkg-source pkg) - staged-checksum - (db:pkg-desc pkg))))) - ;; Record packed result: - (define new-checksum (file->string pkg-checksum-file)) - (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) - (define modules (db:get-pkg-modules name (db:pkg-catalog pkg) (db:pkg-checksum pkg))) - (define dependencies (db:get-pkg-dependencies name (db:pkg-catalog pkg) (db:pkg-checksum pkg))) - (db:set-pkg! name (db:pkg-catalog pkg) - (db:pkg-author pkg) - (path->string (path->complete-path pkg-file)) - new-checksum - (db:pkg-desc pkg)) - (db:set-pkg-modules! name (db:pkg-catalog pkg) - new-checksum - modules) - (db:set-pkg-dependencies! name (db:pkg-catalog pkg) - new-checksum - dependencies)))) - (define dest-catalog (build-path dest-dir "catalog")) - (unless quiet? - (printf/flush "Creating catalog ~a\n" dest-catalog)) - (pkg-catalog-copy (list temp-catalog-file) - (build-path dest-dir "catalog") - #:force? #t - #:override? #t - #:relative-sources? relative-sources?) - (delete-file temp-catalog-file)) - -(define (choose-catalog-file) - (define default (db:current-pkg-catalog-file)) - (if (file-exists? default) - default - (let ([installation (build-path (find-share-dir) "pkgs" (file-name-from-path default))]) - (if (file-exists? installation) - installation - default)))) - -(define (get-all-pkg-scopes) - (append (let ([main (find-pkgs-dir)]) - (reverse - (for/list ([d (get-pkgs-search-dirs)]) - (if (equal? d main) - 'installation - (simple-form-path d))))) - '(user))) - -(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)))) - stringset all-pkg-names)) - (for ([f (in-list (directory-list pkgs-dir))]) - (cond - [(regexp-match #rx"^(.*)[.]zip(?:[.]CHECKSUM)?$" f) - => (lambda (m) - (unless (set-member? keep-pkgs (cadr m)) - (unless quiet? - (printf/flush "Removing old package file ~a\n" f)) - (delete-file (build-path pkgs-dir f))))]))) - - (define (pkg->deps p) - (match-define (pkg deps build-deps) (hash-ref pkgs/deps p)) - ;; NOTE: This include deps that don't get archived. It's not - ;; obvious which is the right decision but I've gone with - ;; including them since for "base" keeping but not archiving - ;; seems like the right choice. - (remove-duplicates (append deps build-deps))) - - ;; Check on each new package: - (for ([(name pkg-i) (in-hash pkgs)]) - (match-define (pkg-info _ checksum _) pkg-i) - (with-handlers ([exn:fail? (λ (exn) (package-exn-handler name exn))]) - (define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name))) - (define pkg-checksum-file (path-replace-suffix pkg-file #".zip.CHECKSUM")) - (define pkg-dir (pkg-directory name)) - - (unless pkg-dir - (pkg-error "no directory found for package \"~a\"" name)) - - (unless quiet? - (printf/flush "== Archiving ~a ==\nchecksum: ~a\n" name checksum)) - ;; Download/unpack existing package: - (define-values (staged-name staged-dir staged-checksum clean? staged-mods) - (pkg-stage - (pkg-desc (path->string pkg-dir) 'dir name checksum #f) - #:in-place? #f - #:use-cache? #t - #:quiet? quiet?)) - (make-directory* (build-path dest-dir "pkgs")) - ;; Repack: - (pkg-create 'zip - staged-dir - #:pkg-name name - #:dest (build-path dest-dir "pkgs") - #:quiet? quiet?) - (when clean? (delete-directory/files staged-dir)) - - ;; Record packed result: - (define new-checksum (file->string pkg-checksum-file)) - (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) - (db:set-pkg! name "local" - "" - (path->string (path->complete-path pkg-file)) - new-checksum - "") - (db:set-pkg-dependencies! name "local" - new-checksum - (pkg->deps name)) - (db:set-pkg-modules! name "local" - new-checksum - (set->list staged-mods))))) - - (define dest-catalog (build-path dest-dir "catalog")) - (unless quiet? - (printf/flush "Creating catalog ~a\n" dest-catalog)) - - - (pkg-catalog-copy (list temp-catalog-file) - (build-path dest-dir "catalog") - #:force? #t - #:override? #t - #:relative-sources? relative-sources?) - (delete-file temp-catalog-file)) + "private/desc.rkt" + "private/dirs.rkt" + "private/params.rkt" + "private/lock.rkt" + "private/pkg-db.rkt" + "private/metadata.rkt" + "private/mod-paths.rkt" + "private/addl-installs.rkt" + "private/catalog.rkt" + "private/remove.rkt" + "private/install.rkt" + "private/stage.rkt" + "private/show.rkt" + "private/config.rkt" + "private/create.rkt" + "private/migrate.rkt" + "private/catalog-copy.rkt" + "private/catalog-show.rkt" + "private/content.rkt" + "private/catalog-update.rkt" + "private/catalog-archive.rkt" + "private/suggestions.rkt" + "private/archive.rkt") (define dep-behavior/c (or/c #f 'fail 'force 'search-ask 'search-auto)) diff --git a/racket/collects/pkg/private/addl-installs.rkt b/racket/collects/pkg/private/addl-installs.rkt new file mode 100644 index 0000000000..7fe41bfd95 --- /dev/null +++ b/racket/collects/pkg/private/addl-installs.rkt @@ -0,0 +1,154 @@ +#lang racket/base +(require racket/set + setup/collection-name + setup/matching-platform + setup/getinfo + "../path.rkt" + "params.rkt" + "metadata.rkt" + "get-info.rkt") + +(provide pkg-directory->additional-installs + directory->additional-installs + get-additional-installed) + +(define (pkg-directory->additional-installs dir pkg-name + #:namespace [metadata-ns (make-metadata-namespace)] + #:system-type [sys-type #f] + #:system-library-subpath [sys-lib-subpath #f]) + (set->list (directory->additional-installs dir pkg-name metadata-ns + #:system-type sys-type + #:system-library-subpath sys-lib-subpath))) + +(define (directory->additional-installs dir pkg-name metadata-ns + #:system-type [sys-type #f] + #:system-library-subpath [sys-lib-subpath #f]) + (define single-collect + (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns)) + (let loop ([s (set)] [f dir] [top? #t] [omits (set)]) + (cond + [(and (directory-exists? f) + (not (set-member? omits (simplify-path f)))) + (define i (get-pkg-info f metadata-ns)) + (define omit-paths (if i + (i 'compile-omit-paths (lambda () null)) + null)) + (cond + [(eq? omit-paths 'all) + s] + [else + (define omit-files (if i + (i 'compile-omit-files (lambda () null)) + null)) + (define new-s + (if (and i (or single-collect (not top?))) + (set-union (extract-additional-installs i sys-type sys-lib-subpath) + s) + s)) + (define new-omits + (set-union + omits + (for/set ([i (in-list (append omit-paths omit-files))]) + (simplify-path (build-path f i))))) + (for/fold ([s new-s]) ([f (directory-list f #:build? #t)]) + (loop s f #f new-omits))])] + [else s]))) + +(define (extract-additional-installs i sys-type sys-lib-subpath) + (define (extract-documents i) + (let ([s (i 'scribblings (lambda () null))]) + (for/set ([doc (in-list (if (list? s) s null))] + #:when (and (list? doc) + (pair? doc) + (path-string? (car doc)) + (or ((length doc) . < . 2) + (list? (cadr doc))) + (or ((length doc) . < . 4) + (collection-name-element? (list-ref doc 3))))) + (define flags (if ((length doc) . < . 2) + null + (cadr doc))) + (cond + [(member 'main-doc-root flags) '(main-doc-root . "root")] + [(member 'user-doc-root flags) '(user-doc-root . "root")] + [else + (cons 'doc + (string-foldcase + (if ((length doc) . < . 4) + (let-values ([(base name dir?) (split-path (car doc))]) + (path->string (path-replace-suffix name #""))) + (list-ref doc 3))))])))) + (define (extract-paths i tag keys) + (define (get k) + (define l (i k (lambda () null))) + (if (and (list? l) (andmap path-string? l)) + l + null)) + (list->set (map (lambda (v) (cons tag + (let-values ([(base name dir?) (split-path v)]) + ;; Normalize case, because some platforms + ;; have case-insensitive filesystems: + (string-foldcase (path->string name))))) + (apply + append + (for/list ([k (in-list keys)]) + (get k)))))) + (define (extract-launchers i) + (extract-paths i 'exe '(racket-launcher-names + mzscheme-launcher-names + gracket-launcher-names + mred-launcher-names))) + (define (extract-foreign-libs i) + (extract-paths i 'lib '(copy-foreign-libs + move-foreign-libs))) + (define (extract-shared-files i) + (extract-paths i 'share '(copy-shared-files + move-shared-files))) + (define (extract-man-pages i) + (extract-paths i 'man '(copy-man-pages + move-man-pages))) + (define (this-platform? i) + (define v (i 'install-platform (lambda () #rx""))) + (or (not (platform-spec? v)) + (matching-platform? v + #:system-type sys-type + #:system-library-subpath sys-lib-subpath))) + (set-union (extract-documents i) + (extract-launchers i) + (if (this-platform? i) + (set-union + (extract-foreign-libs i) + (extract-shared-files i) + (extract-man-pages i)) + (set)))) + +(define (get-additional-installed kind skip-ht-keys ai-cache metadata-ns path-pkg-cache) + (or (unbox ai-cache) + (let () + (define skip-pkgs (list->set (hash-keys skip-ht-keys))) + (define dirs (find-relevant-directories '(scribblings + racket-launcher-names + mzscheme-launcher-names + gracket-launcher-names + mred-launcher-names + copy-foreign-libs + move-foreign-libs + copy-shared-files + move-shared-files + copy-man-pages + move-man-pages) + (if (eq? 'user (current-pkg-scope)) + 'all-available + 'no-user))) + (define s (for/fold ([s (set)]) ([dir (in-list dirs)]) + (cond + [(set-member? skip-pkgs (path->pkg dir #:cache path-pkg-cache)) + s] + [else + (define i (get-pkg-info dir metadata-ns)) + (if i + (set-union s (extract-additional-installs i #f #f)) + s)]))) + (set-box! ai-cache s) + s))) + diff --git a/racket/collects/pkg/private/archive.rkt b/racket/collects/pkg/private/archive.rkt new file mode 100644 index 0000000000..45b32b5998 --- /dev/null +++ b/racket/collects/pkg/private/archive.rkt @@ -0,0 +1,175 @@ +#lang racket/base +(require racket/file + racket/set + racket/match + racket/list + setup/getinfo + "../path.rkt" + (prefix-in db: "../db.rkt") + "dirs.rkt" + "pkg-db.rkt" + "params.rkt" + "print.rkt" + "desc.rkt" + "stage.rkt" + "create.rkt" + "catalog-copy.rkt") + +(provide pkg-archive-pkgs) + +(define (pkg-archive-pkgs dest-dir pkg-names + #:include-deps? [include-deps? #f] + #:exclude [exclude null] + #:relative-sources? [relative-sources? #f] + #:quiet? [quiet? #f] + #:package-exn-handler [package-exn-handler + (λ (name exn) (raise exn))]) + (struct pkg (deps build-deps) #:transparent) + (define (extract-pkg p) (if (string? p) p (car p))) + + (define (add-package-from-dir src-f f-name pkgs) + (define i (get-info/full src-f)) + (cond + [i + (hash-set pkgs f-name (pkg (map extract-pkg (i 'deps (lambda () null))) + (map extract-pkg (i 'build-deps (lambda () null)))))] + [else pkgs])) + + (define unfiltered-pkgs + (for/fold ([pkgs (hash)]) ([pkg-scope (in-list (get-all-pkg-scopes))]) + (define pkg-names (installed-pkg-names #:scope pkg-scope)) + (parameterize ([current-pkg-scope pkg-scope]) + (for/fold ([pkgs pkgs]) ([pkg (in-list pkg-names)]) + (define dir (pkg-directory pkg)) + (cond [dir (add-package-from-dir dir pkg pkgs)] + [else pkgs]))))) + + (define exclude+ (list* "base" "racket" exclude)) + + (for ([p (in-list pkg-names)]) + (unless (hash-ref unfiltered-pkgs p #f) + (pkg-error "cannot archive package \"~a\" because it is not installed" p))) + + ;; Filter to roots: + (define pkgs/deps + (cond + [(not include-deps?) + (for/hash ([(k v) (in-hash unfiltered-pkgs)] + #:when (member k pkg-names)) + (values k v))] + [else + (define seen (make-hash)) + (define (loop pkg) + (cond + [(member pkg exclude+) (void)] + [(hash-ref seen pkg #f) (void)] + [else + (define p (hash-ref unfiltered-pkgs pkg #f)) + (when p + (hash-set! seen pkg #t) + (for-each loop (pkg-deps p)) + (for-each loop (pkg-build-deps p)))])) + (for-each loop pkg-names) + (for/hash ([(k v) (in-hash unfiltered-pkgs)] + #:when (hash-ref seen k #f)) + (values k v))])) + + (define all-pkg-names (hash-keys pkgs/deps)) + + ;; The temporary catalog we'll create, simulating the current install + (define temp-catalog-file (make-temporary-file "pkg~a.sqlite")) + ;; all the current installed packages + (define all-installed-pkgs + (for*/hash ([scope (in-list (get-all-pkg-scopes))] + [(k v) (in-hash (read-pkgs-db scope))]) + (values k v))) + + ;; get the pkg descriptions we want + (define pkgs + (for/hash ([p (in-list all-pkg-names)]) + (values p + (hash-ref all-installed-pkgs p + (λ _ (pkg-error + "cannot archive package \"~a\" because it is not installed" p)))))) + + ;; set up temporary catalog with the right packages + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" all-pkg-names)) + + ;; Remove any package not in `pkgs`: + (define pkgs-dir (build-path dest-dir "pkgs")) + (when (directory-exists? pkgs-dir) + (define keep-pkgs (list->set all-pkg-names)) + (for ([f (in-list (directory-list pkgs-dir))]) + (cond + [(regexp-match #rx"^(.*)[.]zip(?:[.]CHECKSUM)?$" f) + => (lambda (m) + (unless (set-member? keep-pkgs (cadr m)) + (unless quiet? + (printf/flush "Removing old package file ~a\n" f)) + (delete-file (build-path pkgs-dir f))))]))) + + (define (pkg->deps p) + (match-define (pkg deps build-deps) (hash-ref pkgs/deps p)) + ;; NOTE: This include deps that don't get archived. It's not + ;; obvious which is the right decision but I've gone with + ;; including them since for "base" keeping but not archiving + ;; seems like the right choice. + (remove-duplicates (append deps build-deps))) + + ;; Check on each new package: + (for ([(name pkg-i) (in-hash pkgs)]) + (match-define (pkg-info _ checksum _) pkg-i) + (with-handlers ([exn:fail? (λ (exn) (package-exn-handler name exn))]) + (define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name))) + (define pkg-checksum-file (path-replace-suffix pkg-file #".zip.CHECKSUM")) + (define pkg-dir (pkg-directory name)) + + (unless pkg-dir + (pkg-error "no directory found for package \"~a\"" name)) + + (unless quiet? + (printf/flush "== Archiving ~a ==\nchecksum: ~a\n" name checksum)) + ;; Download/unpack existing package: + (define-values (staged-name staged-dir staged-checksum clean? staged-mods) + (pkg-stage + (pkg-desc (path->string pkg-dir) 'dir name checksum #f) + #:in-place? #f + #:use-cache? #t + #:quiet? quiet?)) + (make-directory* (build-path dest-dir "pkgs")) + ;; Repack: + (pkg-create 'zip + staged-dir + #:pkg-name name + #:dest (build-path dest-dir "pkgs") + #:quiet? quiet?) + (when clean? (delete-directory/files staged-dir)) + + ;; Record packed result: + (define new-checksum (file->string pkg-checksum-file)) + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (db:set-pkg! name "local" + "" + (path->string (path->complete-path pkg-file)) + new-checksum + "") + (db:set-pkg-dependencies! name "local" + new-checksum + (pkg->deps name)) + (db:set-pkg-modules! name "local" + new-checksum + (set->list staged-mods))))) + + (define dest-catalog (build-path dest-dir "catalog")) + (unless quiet? + (printf/flush "Creating catalog ~a\n" dest-catalog)) + + + (pkg-catalog-copy (list temp-catalog-file) + (build-path dest-dir "catalog") + #:force? #t + #:override? #t + #:relative-sources? relative-sources?) + (delete-file temp-catalog-file)) diff --git a/racket/collects/pkg/private/catalog-archive.rkt b/racket/collects/pkg/private/catalog-archive.rkt new file mode 100644 index 0000000000..0fc5a9fc3c --- /dev/null +++ b/racket/collects/pkg/private/catalog-archive.rkt @@ -0,0 +1,125 @@ +#lang racket/base +(require racket/format + racket/file + racket/set + openssl/sha1 + (prefix-in db: "../db.rkt") + "catalog.rkt" + "catalog-copy.rkt" + "print.rkt" + "stage.rkt" + "desc.rkt" + "create.rkt") + +(provide pkg-catalog-archive) + +(define (pkg-catalog-archive dest-dir + src-catalogs + #:from-config? [from-config? #f] + #:state-catalog [state-catalog #f] + #:relative-sources? [relative-sources? #f] + #:quiet? [quiet? #f] + #:package-exn-handler [package-exn-handler (lambda (name exn) (raise exn))]) + (when (and state-catalog + (not (db-path? (if (path? state-catalog) + state-catalog + (string->path state-catalog))))) + (pkg-error (~a "bad state file path\n" + " given: ~a\n" + " expected: path with \".sqlite\" extension") + state-catalog)) + ;; Take a snapshot of the source catalog: + (define temp-catalog-file (make-temporary-file "pkg~a.sqlite")) + (pkg-catalog-copy (map url-or-path->url-string + (map src->url-or-path src-catalogs)) + temp-catalog-file + #:force? #t ; replaces temporary file + #:from-config? from-config?) + (define pkgs + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (db:get-pkgs))) + ;; Reset state catalog to new packages: + (when state-catalog + (parameterize ([db:current-pkg-catalog-file state-catalog]) + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" (map db:pkg-name pkgs)))) + ;; Remove any package not in `pkgs`: + (define pkgs-dir (build-path dest-dir "pkgs")) + (when (directory-exists? pkgs-dir) + (define keep-pkgs (list->set (map db:pkg-name pkgs))) + (for ([f (in-list (directory-list pkgs-dir))]) + (cond + [(regexp-match #rx"^(.*)[.]zip(?:[.]CHECKSUM)?$" f) + => (lambda (m) + (unless (set-member? keep-pkgs (cadr m)) + (unless quiet? + (printf/flush "Removing old package file ~a\n" f)) + (delete-file (build-path pkgs-dir f))))]))) + ;; Check on each new package: + (for ([pkg (in-list (sort pkgs stringstring pkg-checksum-file) + (call-with-input-file* pkg-file sha1))) + (unless quiet? + (printf/flush "== Archiving ~a ==\nchecksum: ~a\n" (db:pkg-name pkg) (db:pkg-checksum pkg))) + ;; Download/unpack existing package: + (define-values (staged-name staged-dir staged-checksum clean? staged-mods) + (pkg-stage + (pkg-desc (db:pkg-source pkg) #f (db:pkg-name pkg) (db:pkg-checksum pkg) #f) + #:in-place? #t + #:use-cache? #t + #:quiet? quiet?)) + (make-directory* (build-path dest-dir "pkgs")) + ;; Repack: + (pkg-create 'zip + staged-dir + #:pkg-name name + #:dest (build-path dest-dir "pkgs") + #:quiet? quiet?) + (when clean? (delete-directory/files staged-dir)) + ;; Record packed result: + (when state-catalog + (parameterize ([db:current-pkg-catalog-file state-catalog]) + (db:set-pkg! name "local" + (db:pkg-author pkg) + (db:pkg-source pkg) + staged-checksum + (db:pkg-desc pkg))))) + ;; Record packed result: + (define new-checksum (file->string pkg-checksum-file)) + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (define modules (db:get-pkg-modules name (db:pkg-catalog pkg) (db:pkg-checksum pkg))) + (define dependencies (db:get-pkg-dependencies name (db:pkg-catalog pkg) (db:pkg-checksum pkg))) + (db:set-pkg! name (db:pkg-catalog pkg) + (db:pkg-author pkg) + (path->string (path->complete-path pkg-file)) + new-checksum + (db:pkg-desc pkg)) + (db:set-pkg-modules! name (db:pkg-catalog pkg) + new-checksum + modules) + (db:set-pkg-dependencies! name (db:pkg-catalog pkg) + new-checksum + dependencies)))) + (define dest-catalog (build-path dest-dir "catalog")) + (unless quiet? + (printf/flush "Creating catalog ~a\n" dest-catalog)) + (pkg-catalog-copy (list temp-catalog-file) + (build-path dest-dir "catalog") + #:force? #t + #:override? #t + #:relative-sources? relative-sources?) + (delete-file temp-catalog-file)) diff --git a/racket/collects/pkg/private/catalog-copy.rkt b/racket/collects/pkg/private/catalog-copy.rkt new file mode 100644 index 0000000000..c64e338d40 --- /dev/null +++ b/racket/collects/pkg/private/catalog-copy.rkt @@ -0,0 +1,162 @@ +#lang racket/base +(require racket/format + racket/file + net/url + (prefix-in db: "../db.rkt") + "config.rkt" + "catalog.rkt" + "print.rkt" + "params.rkt") + +(provide pkg-catalog-copy + src->url-or-path + url-or-path->url-string) + +(define (src->url-or-path src) + (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 a catalog\n" + " URL: ~a") + src)] + [else (path->complete-path src)])) + +(define (url-or-path->url-string p) + (url->string (if (url? p) + p + (path->url p)))) + +(define (pkg-catalog-copy srcs dest + #:from-config? [from-config? #f] + #:merge? [merge? #f] + #:force? [force? #f] + #:override? [override? #f] + #:relative-sources? [relative-sources? #f]) + (define src-paths + (for/list ([src (in-list (append srcs + (if from-config? + (pkg-config-catalogs) + null)))]) + (define src-path (src->url-or-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)])) + + (define dest-dir + (and relative-sources? + (if (db-path? dest-path) + (let-values ([(base name dir?) (split-path dest-path)]) + base) + dest-path))) + + (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 absolute-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)))) + (define details + (if relative-sources? + (for/hash ([(k ht) (in-hash absolute-details)]) + (values k (source->relative-source dest-dir ht))) + absolute-details)) + + (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) + (define vers-details + (for/hash ([(k v) (in-hash details)]) + (values k (select-info-version v)))) + (parameterize ([db:current-pkg-catalog-file dest-path]) + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" + (for/list ([(k v) (in-hash vers-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 vers-details)]) + (define t (hash-ref v 'tags '())) + (unless (null? t) + (db:set-pkg-tags! k "local" t))) + (for ([(k v) (in-hash vers-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 vers-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)))])) + diff --git a/racket/collects/pkg/private/catalog-show.rkt b/racket/collects/pkg/private/catalog-show.rkt new file mode 100644 index 0000000000..2ecd4f18e1 --- /dev/null +++ b/racket/collects/pkg/private/catalog-show.rkt @@ -0,0 +1,82 @@ +#lang racket/base +(require racket/format + "../name.rkt" + "catalog.rkt" + "dep.rkt" + "path.rkt" + "print.rkt") + +(provide pkg-catalog-show) + +(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? + (sort (hash-keys all-details) stringstring 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 (pretty-module-path mod)) + (define mod-str (~a " " (~s pretty-mod))) + (define new-col (if ((+ col (string-length mod-str)) . > . 72) + (begin + (printf "\n ") + 0) + col)) + (display mod-str) + (+ new-col (string-length mod-str))) + (newline)))])) + diff --git a/racket/collects/pkg/private/catalog-update.rkt b/racket/collects/pkg/private/catalog-update.rkt new file mode 100644 index 0000000000..b244e91dd6 --- /dev/null +++ b/racket/collects/pkg/private/catalog-update.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require racket/format + racket/list + net/url + (prefix-in db: "../db.rkt") + "params.rkt" + "catalog.rkt" + "content.rkt" + "config.rkt" + "print.rkt" + "desc.rkt") + +(provide pkg-catalog-update-local) + +(define (pkg-catalog-update-local #:catalogs [catalogs (pkg-config-catalogs)] + #:set-catalogs? [set-catalogs? #t] + #:catalog-file [catalog-file (db:current-pkg-catalog-file)] + #:quiet? [quiet? #f] + #:consult-packages? [consult-packages? #f] + #:skip-download-failures? [skip-download-failures? #f]) + (parameterize ([db:current-pkg-catalog-file catalog-file]) + (define current-catalogs (db:get-catalogs)) + (cond + [set-catalogs? + (unless (equal? catalogs current-catalogs) + (db:set-catalogs! catalogs))] + [else + (unless (for/and ([catalog (in-list catalogs)]) + (member catalog current-catalogs)) + (error 'pkg-catalog-update-local + (~a "given catalog list is not a superset of recorded catalogs\n" + " given: ~s\n" + " recorded: ~s") + catalogs + current-catalogs))]) + + (for ([catalog (in-list catalogs)]) + (unless quiet? + (printf/flush "Updating from ~a\n" catalog)) + (parameterize ([current-pkg-catalogs (list (string->url catalog))]) + (define details (for/hash ([(name ht) (get-all-pkg-details-from-catalogs)]) + (values name (select-info-version ht)))) + ;; 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 tags (hash-ref ht 'tags #f)) + (when tags + (db:set-pkg-tags! name catalog tags)) + (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/flush "Downloading ~s\n" source)) + (define-values (checksum modules deps) + (get-pkg-content (pkg-desc source + #f + name + (hash-ref ht 'checksum #f) + #f))) + (db:set-pkg-modules! name catalog checksum modules) + (db:set-pkg-dependencies! name catalog checksum deps))))))) + diff --git a/racket/collects/pkg/private/catalog.rkt b/racket/collects/pkg/private/catalog.rkt new file mode 100644 index 0000000000..6b573ac4a8 --- /dev/null +++ b/racket/collects/pkg/private/catalog.rkt @@ -0,0 +1,306 @@ +#lang racket/base +(require net/url + racket/path + racket/format + racket/port + (prefix-in db: "../db.rkt") + "../name.rkt" + "params.rkt" + "config.rkt" + "print.rkt") + +(provide select-info-version + source->relative-source + package-catalog-lookup + get-all-pkg-names-from-catalogs + get-pkg-details-from-catalogs + get-all-pkg-details-from-catalogs + db-path?) + +(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 #f])] + [else (server i)])) + +;; Add current package version to a URL: +(define (add-version-query addr/no-query) + (struct-copy url addr/no-query + [query (append + (url-query addr/no-query) + (list + (cons 'version (current-pkg-lookup-version))))])) + +;; Take a package-info hash table and lift any version-specific +;; information in 'versions. +(define (select-info-version ht) + (and ht + (let ([v (hash-ref ht 'versions #f)]) + (cond + [(hash? v) + (or (for/or ([vers (in-list (list (current-pkg-lookup-version) + 'default))]) + (define ht2 (hash-ref v vers #f)) + (and ht2 + ;; Override fields of `ht' with values from `ht2': + (for/fold ([ht ht]) ([(k v) (in-hash ht2)]) + (hash-set ht k v)))) + ;; Keep ht as-is: + ht)] + [else ht])))) + +;; If the 'source field in `ht` is a relative path, treat +;; it as relative to `i` and make it absolute: +(define (source->absolute-source i ht) + (cond + [ht + (define s (hash-ref ht 'source #f)) + (define new-ht + (cond + [s + ;; If `s' is a relative URL, then we rely on the pun + ;; that it will parse as a relative path. + (define-values (name type) (package-source->name+type s #f)) + (cond + [(and (or (eq? type 'dir) (eq? type 'file)) + (not (regexp-match? #rx"^file://" s)) + (relative-path? s)) + (define i-for-combine + (cond + [(equal? "file" (url-scheme i)) + (define i-path (url->path i)) + (if (db-path? i-path) + i + ;; Make sure we interpret `i' as a directory when + ;; adding a relative path: + (path->url (path->directory-path (url->path i))))] + [else i])) + (define full-url + (url->string + (combine-url/relative i-for-combine s))) + (hash-set ht 'source full-url)] + [else ht])] + [else ht])) + (let ([v (hash-ref new-ht 'versions #f)]) + (if v + ;; Adjust version-specific sources: + (hash-set new-ht 'versions + (for/hash ([(k ht) (in-hash v)]) + (values k (source->absolute-source i ht)))) + ;; No further adjustments: + new-ht))] + [else #f])) + +;; Make sources in `ht` relative to `dir`, when possible: +(define (source->relative-source dir ht) + (define s (hash-ref ht 'source #f)) + (define new-ht + (cond + [s + (define-values (name type) (package-source->name+type s #f)) + (cond + [(or (eq? type 'dir) (eq? type 'file)) + (hash-set ht + 'source + (relative-path->relative-url-string + (find-relative-path + dir + (package-source->path s type))))] + [else ht])] + [else ht])) + (let ([v (hash-ref new-ht 'versions #f)]) + (if v + ;; Adjust version-specific sources: + (hash-set new-ht 'versions + (for/hash ([(k ht) (in-hash new-ht)]) + (values k (source->relative-source dir ht)))) + ;; No further adjustments: + new-ht))) + +(define (package-catalog-lookup pkg details? download-printf) + (or + (for/or ([i (in-list (pkg-catalogs))]) + (if download-printf + (download-printf "Resolving ~s via ~a\n" pkg (url->string i)) + (log-pkg-debug "consulting catalog ~a" (url->string i))) + (source->absolute-source + i + (select-info-version + (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 (read-from-server who url pred + [failure + (lambda (s) + (error who + (~a "bad response from server\n" + " url: ~a\n" + " response: ~v") + (url->string url) + s))]) + (define bytes (call-with-url url port->bytes)) + ((if bytes + (with-handlers ([exn:fail:read? (lambda (exn) + (lambda () (failure bytes)))]) + (define v (read (open-input-bytes bytes))) + (lambda () + (if (pred v) + v + (failure bytes)))) + (lambda () (failure #f))))) + +;; uses a custodian to avoid leaks: +(define (call-with-url url handler) + (define c (make-custodian)) + (dynamic-wind + void + (lambda () + (define-values (p hs) + (parameterize ([current-custodian c]) + (get-pure-port/headers url #:redirections 25 #:status? #t))) + (begin0 + (and (string=? "200" (substring hs 9 12)) + (handler p)) + (close-input-port p))) + (lambda () + (custodian-shutdown-all c)))) + +(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-checksum pkg)))) + + +(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) stringstring i) + (call-with-input-file* (build-path pkg-path i) + read)))])))) + (unless one-ht + (pkg-error (~a "could not read package catalog\n" + " catalog: ~a") + (url->string i))) + (for/fold ([ht ht]) ([(k v) (in-hash one-ht)]) + (if (hash-ref ht k #f) + ht + (hash-set ht k (source->absolute-source i v)))))) diff --git a/racket/collects/pkg/private/collects.rkt b/racket/collects/pkg/private/collects.rkt new file mode 100644 index 0000000000..680f7c8f54 --- /dev/null +++ b/racket/collects/pkg/private/collects.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require setup/pack + racket/set + "dep.rkt" + "pkg-db.rkt" + "get-info.rkt" + "metadata.rkt" + "print.rkt") + +;; Package collection and dependency information needed for +;; installation and removal of packages. + +(provide package-collections + package-collection-directories + package-dependencies + get-setup-collects) + +(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 ((package-dependencies metadata-ns db all-platforms? + #:only-implies? [only-implies? #f]) + pkg-name) + (define pkg-dir (pkg-directory* pkg-name #:db db)) + (define deps + (map dependency->name + (let ([l (get-all-deps metadata-ns pkg-dir)]) + (if all-platforms? + l + (filter dependency-this-platform? l))))) + (if only-implies? + (let ([implies (list->set (get-all-implies metadata-ns pkg-dir deps))]) + (filter (lambda (dep) + (set-member? implies dep)) + deps)) + deps)) + +(define (maybe-append lists) + (and (for/and ([v (in-list lists)]) (not (eq? v 'all))) + (apply append lists))) + +(define (get-setup-collects pkg-names db metadata-ns) + (maybe-append + (for/list ([pkg-name (in-list pkg-names)]) + (define pkg-dir (pkg-directory* pkg-name #:db db)) + (define single-collect + (and pkg-dir + (pkg-single-collection pkg-dir #:name pkg-name #:namespace metadata-ns))) + (or (and (not pkg-dir) null) + (and single-collect (list single-collect)) + (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)))))))) diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt new file mode 100644 index 0000000000..31ee2ff4c7 --- /dev/null +++ b/racket/collects/pkg/private/config.rkt @@ -0,0 +1,202 @@ +#lang racket/base +(require setup/dirs + racket/file + racket/match + racket/format + net/url + "../path.rkt" + "dirs.rkt" + "params.rkt" + "lock.rkt" + "print.rkt") + +;; Reading and writing the package-relevant configuration of +;; an installation or for the current user. + +(provide (all-defined-out)) + +(define (get-download-cache-dir) + (or (current-pkg-download-cache-dir) + (read-pkg-cfg/def 'download-cache-dir))) +(define (get-download-cache-max-files) + (or (current-pkg-download-cache-max-files) + (read-pkg-cfg/def 'download-cache-max-files))) +(define (get-download-cache-max-bytes) + (or (current-pkg-download-cache-max-bytes) + (read-pkg-cfg/def 'download-cache-max-bytes))) + +(define (read-pkg-cfg/def k) + ;; Lock is held for the current scope, but if + ;; the key is not found in the current scope, + ;; get the next scope's lock and try there, + ;; etc. + (define (get-default) + (match k + ['catalogs + (list "http://pkgs.racket-lang.org" + "http://planet-compats.racket-lang.org")] + ['default-scope "user"] + ['installation-name (version)] + ['download-cache-dir (build-path (find-system-path 'addon-dir) + "download-cache")] + ['download-cache-max-files 1024] + ['download-cache-max-bytes (* 64 1024 1024)] + [_ #f])) + (define c (read-pkg-file-hash (pkg-config-file))) + (define v (hash-ref c k 'none)) + (cond + [(eq? v 'none) + ;; Default from enclosing scope or hard-wired default: + (define s (current-pkg-scope)) + (if (eq? s 'installation) + ;; Hard-wided: + (get-default) + ;; Enclosing: + (parameterize ([current-pkg-scope 'installation]) + (read-pkg-cfg/def k)))] + [else + (match k + ['catalogs + (if (member #f v) + ;; Replace #f with default URLs: + (apply append (for/list ([i (in-list v)]) + (if (not i) + (get-default) + (list i)))) + v)] + [_ v])])) + +(define (update-pkg-cfg! key val) + (define f (pkg-config-file)) + (write-file-hash! + f + (hash-set (read-pkg-file-hash f) key val))) + +(define (default-pkg-scope) + (match (default-pkg-scope-as-string) + ["installation" 'installation] + [else 'user])) +(define (default-pkg-scope-as-string) + (read-pkg-cfg/def 'default-scope)) + +(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 (pkg-config config:set key+vals + #:from-command-line? [from-command-line? #f]) + (cond + [config:set + (match key+vals + [(list) + (pkg-error "no config key given")] + [(list (and key + (or "default-scope" + "name" + "download-cache-max-files" + "download-cache-max-bytes" + "download-cache-dir" + "doc-open-url"))) + (pkg-error (~a "missing value for config key\n" + " config key: ~a") + key)] + [(list* (and key + (or "default-scope" + "name" + "download-cache-max-files" + "download-cache-max-bytes" + "download-cache-dir")) + val + another-val + more-vals) + (pkg-error (~a "too many values provided for config key\n" + " config key: ~a\n" + " given values:~a") + key + (format-list (cons val more-vals)))] + [(list* (and key "catalogs") val) + (update-pkg-cfg! 'catalogs val)] + [(list (and key "default-scope") val) + (unless (member val '("installation" "user")) + (pkg-error (~a "invalid value for config key\n" + " config key: ~a\n" + " given value: ~a\n" + " valid values: installation, user") + key + val)) + (update-pkg-cfg! 'default-scope val)] + [(list (and key "name") val) + (unless (eq? 'installation (current-pkg-scope)) + (pkg-error (~a "setting `name' makes sense only in `installation' scope\n" + " current package scope: ~a") + (current-pkg-scope))) + (update-pkg-cfg! 'installation-name val)] + [(list (and key "download-cache-dir") + val) + (update-pkg-cfg! (string->symbol key) (if (complete-path? val) + val + (path->string + (path->complete-path val))))] + [(list (and key (or "download-cache-max-files" + "download-cache-max-bytes")) + val) + (unless (real? (string->number val)) + (pkg-error (~a "invalid value for config key\n" + " config key: ~a\n" + " given value: ~a\n" + " valid values: real numbers") + key + val)) + (update-pkg-cfg! (string->symbol key) (string->number val))] + [(list (and key "doc-open-url") val) + (unless (eq? 'installation (current-pkg-scope)) + (pkg-error (~a "setting `doc-open-url' works only in `installation' scope\n" + " current package scope: ~a") + (current-pkg-scope))) + (update-pkg-cfg! 'doc-open-url (if (equal? val "") #f val))] + [(list* key args) + (pkg-error "unsupported config key\n key: ~a" key)])] + [else + (define (show key+vals indent) + (match key+vals + [(list key) + (match key + ["catalogs" + (for ([s (in-list (read-pkg-cfg/def 'catalogs))]) + (printf "~a~a\n" indent s))] + ["default-scope" + (printf "~a~a\n" indent (read-pkg-cfg/def 'default-scope))] + ["name" + (printf "~a~a\n" indent (read-pkg-cfg/def 'installation-name))] + [(or "download-cache-dir" + "download-cache-max-files" + "download-cache-max-bytes") + (printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))] + ["doc-open-url" + (printf "~a~a\n" indent (or (read-pkg-cfg/def 'doc-open-url) ""))] + [_ + (pkg-error "unsupported config key\n key: ~e" key)])] + [(list) + (pkg-error "config key not provided")] + [_ + (pkg-error (~a "multiple config keys provided" + (if from-command-line? + ";\n supply `--set' to set a config key's value" + "")))])) + (match key+vals + [(list) + (for ([key (in-list '("name" + "catalogs" + "default-scope" + "download-cache-dir" + "download-cache-max-files" + "download-cache-max-bytes"))]) + (printf "~a:\n" key) + (show (list key) " "))] + [_ (show key+vals "")])])) diff --git a/racket/collects/pkg/private/content.rkt b/racket/collects/pkg/private/content.rkt new file mode 100644 index 0000000000..3402bd1e06 --- /dev/null +++ b/racket/collects/pkg/private/content.rkt @@ -0,0 +1,50 @@ +#lang racket/base +(require racket/list + racket/set + racket/file + setup/getinfo + "get-info.rkt" + "dep.rkt" + "metadata.rkt" + "stage.rkt") + +(provide extract-pkg-dependencies + get-pkg-content) + +(define (extract-pkg-dependencies get-info + #:build-deps? [build-deps? #t] + #:filter? [filter? #f] + #:versions? [versions? #f]) + (define v (if get-info + (get-info 'deps (lambda () empty)) + empty)) + ((check-dependencies 'deps) v) + (define v2 (if (and get-info build-deps?) + (get-info 'build-deps (lambda () empty)) + empty)) + ((check-dependencies 'build-deps) v2) + (define all-v (append v v2)) + (if filter? + (for/list ([dep (in-list all-v)] + #:when (dependency-this-platform? dep)) + (define name + (if (pair? dep) + (car dep) + dep)) + (if versions? + (list name (dependency->version dep)) + name)) + all-v)) + +(define (get-pkg-content desc + #:namespace [metadata-ns (make-metadata-namespace)] + #:extract-info [extract-info extract-pkg-dependencies]) + (define-values (pkg-name dir cksum clean? module-paths) + (pkg-stage desc #:in-place? #t #:namespace metadata-ns)) + (define get-info (get-info/full dir #:namespace metadata-ns)) + (begin0 + (values cksum + (set->list module-paths) + (extract-info get-info)) + (when clean? + (delete-directory/files dir)))) diff --git a/racket/collects/pkg/private/create.rkt b/racket/collects/pkg/private/create.rkt new file mode 100644 index 0000000000..4efe46aa9a --- /dev/null +++ b/racket/collects/pkg/private/create.rkt @@ -0,0 +1,196 @@ +#lang racket/base +(require racket/match + racket/format + racket/file + setup/pack + file/zip + file/tar + openssl/sha1 + "../strip.rkt" + "metadata.rkt" + "print.rkt" + "params.rkt" + "pkg-db.rkt" + "lock.rkt") + +(provide pkg-create) + +(define (create-as-is create:format pkg-name dir orig-dir + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f] + #:hide-src? [hide-src? #f] + #:dest [dest-dir #f]) + (begin + (unless (directory-exists? dir) + (pkg-error "directory does not exist\n path: ~a" dir)) + (match create:format + ['MANIFEST + (unless quiet? + (printf/flush "creating manifest for ~a\n" + orig-dir)) + (with-output-to-file (build-path (or dest-dir 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" pkg-name create:format)) + (define actual-dest-dir (if dest-dir + (path->complete-path dest-dir) + (let-values ([(base name dir?) (split-path dir)]) + (cond + [(path? base) (path->complete-path base)] + [else (current-directory)])))) + (define pkg/complete (path->complete-path pkg actual-dest-dir)) + ;; To make checksums more consistent, set a directory's timestamp to + ;; the latest time of any of its source files. + (define (use-real-timestamp? p) + (and (file-exists? p) + (regexp-match? #rx"[.](?:rkt|ss|scrbl|txt)$" p))) + (define latest-timestamp + (for/fold ([ts #f]) ([f (in-directory dir)]) + (define fts (and (use-real-timestamp? f) + (file-or-directory-modify-seconds f))) + (if (and fts (or (not ts) (fts . > . ts))) + fts + ts))) + (define (file-or-directory-timestamp p) + (or (and (not (use-real-timestamp? p)) + latest-timestamp) + (file-or-directory-modify-seconds p))) + (unless quiet? + (printf/flush "packing~a into ~a\n" + (if hide-src? "" (format " ~a" dir)) + (if dest-dir + pkg/complete + pkg))) + (define (add-directory-layer? content) + ;; We need to add a layer for zip/tgz if the package content + ;; is a single directory, which is an unlikely case. + ;; That mode is not compatble with Racket v60.0.1.12 and earlier. + ;; When only Racket v6.0.1.12 is later is relevant, + ;; we might prefer to always add a layer for consistency and + ;; because it's nicer for manual unpacking. + (and (= 1 (length content)) + (directory-exists? (car content)))) + (match create:format + ['tgz + (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))]) + (define content (directory-list)) + (apply tar-gzip pkg/complete content + #:path-prefix (and (add-directory-layer? content) + pkg-name) + #:get-timestamp file-or-directory-timestamp)))] + ['zip + (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))]) + (define content (directory-list)) + (apply zip pkg/complete content + #:path-prefix (and (add-directory-layer? content) + pkg-name) + #:get-timestamp file-or-directory-timestamp + #:utc-timestamps? #t + #:round-timestamps-down? #t)))] + ['plt + (define dest pkg/complete) + (when (pkg-single-collection #:name pkg-name dir) + (pkg-error (~a "single-collection package not supported in .plt format\n" + " directory: ~a") + dir)) + (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)) + (define chk/complete (path->complete-path chk actual-dest-dir)) + (unless quiet? + (printf/flush "writing package checksum to ~a\n" + (if dest-dir + chk/complete + chk))) + (with-output-to-file chk/complete + #:exists 'replace + (λ () (display (call-with-input-file pkg/complete sha1))))]))) + +(define (stripped-create mode name dir + #:format [create:format 'zip] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f] + #:dest [archive-dest-dir #f]) + (define tmp-dir (make-temporary-file "create-binary-~a" 'directory)) + (dynamic-wind + void + (lambda () + (define dest-dir (build-path tmp-dir name)) + (make-directory dest-dir) + (generate-stripped-directory mode dir dest-dir) + (create-as-is create:format name dest-dir dir + #:hide-src? #t + #:quiet? quiet? + #:from-command-line? from-command-line? + #:dest (if archive-dest-dir + (path->complete-path archive-dest-dir) + (current-directory)))) + (lambda () + (delete-directory/files tmp-dir)))) + +(define (pkg-create create:format dir-or-name + #:pkg-name [given-pkg-name #f] + #:dest [dest-dir #f] + #:source [source 'dir] + #:mode [mode 'as-is] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f]) + (define pkg-name + (or given-pkg-name + (if (eq? source 'dir) + (path->string (let-values ([(base name dir?) (split-path dir-or-name)]) + name)) + dir-or-name))) + (define dir + (if (eq? source 'dir) + dir-or-name + (let () + (define (get-dir scope) + (parameterize ([current-pkg-scope scope]) + (with-pkg-lock/read-only + (pkg-directory* dir-or-name)))) + (define dir (get-dir 'user)) + (unless dir + (pkg-error (~a "package not installed in user scope\n" + " package name: ~a" + (if (get-dir 'installation) + "\n installed in scope: installation" + "")) + dir-or-name)) + dir))) + (case mode + [(as-is) + (create-as-is create:format pkg-name dir dir + #:dest dest-dir + #:quiet? quiet? + #:from-command-line? from-command-line?)] + [else (stripped-create mode pkg-name dir + #:dest dest-dir + #:format create:format + #:quiet? quiet? + #:from-command-line? from-command-line?)])) diff --git a/racket/collects/pkg/private/dep.rkt b/racket/collects/pkg/private/dep.rkt new file mode 100644 index 0000000000..28a34eeb6c --- /dev/null +++ b/racket/collects/pkg/private/dep.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require setup/matching-platform + "../name.rkt") + +(provide (all-defined-out)) + +(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)) + (or (not p) (matching-platform? p))) + diff --git a/racket/collects/pkg/private/desc.rkt b/racket/collects/pkg/private/desc.rkt new file mode 100644 index 0000000000..2511e636e9 --- /dev/null +++ b/racket/collects/pkg/private/desc.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(provide (struct-out pkg-desc) + pkg-desc=?) + +(struct pkg-desc (source type name checksum auto?)) + +(define (pkg-desc=? a b) + (define (->list a) + (list (pkg-desc-source a) + (pkg-desc-type a) + (pkg-desc-name a) + (pkg-desc-checksum a) + (pkg-desc-auto? a))) + (equal? (->list a) (->list b))) diff --git a/racket/collects/pkg/private/dirs.rkt b/racket/collects/pkg/private/dirs.rkt new file mode 100644 index 0000000000..fe793a0108 --- /dev/null +++ b/racket/collects/pkg/private/dirs.rkt @@ -0,0 +1,38 @@ +#lang racket/base +(require setup/dirs + racket/file + racket/path + "../path.rkt" + "params.rkt") + +;; Finding configurable files and directories + +(provide (all-defined-out)) + +(define (pkg-dir config?) + (define scope (current-pkg-scope)) + (if (and config? + (eq? scope 'installation)) + (find-config-dir) + (get-pkgs-dir scope (current-pkg-scope-version)))) + +(define (pkg-config-file) + (build-path (pkg-dir #t) "config.rktd")) + +(define (pkg-db-file) + (build-path (pkg-dir #f) "pkgs.rktd")) + +(define (pkg-installed-dir) + (pkg-dir #f)) + +(define (pkg-lock-file) + (make-lock-file-name (pkg-db-file))) + +(define (get-all-pkg-scopes) + (append (let ([main (find-pkgs-dir)]) + (reverse + (for/list ([d (get-pkgs-search-dirs)]) + (if (equal? d main) + 'installation + (simple-form-path d))))) + '(user))) diff --git a/racket/collects/pkg/private/download.rkt b/racket/collects/pkg/private/download.rkt new file mode 100644 index 0000000000..fc8ef2967e --- /dev/null +++ b/racket/collects/pkg/private/download.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require file/cache + net/url + racket/match + racket/port + racket/format + "path.rkt" + "print.rkt" + "config.rkt") + +(provide call/input-url+200 + download-file! + url-path/no-slash + clean-cache) + +(define (call/input-url+200 u fun + #:headers [headers '()] + #:failure [fail-k (lambda (s) #f)]) + #;(printf "\t\tReading ~a\n" (url->string u)) + (define-values (ip hs) (get-pure-port/headers u headers + #:redirections 25 + #:status? #t)) + (if (string=? "200" (substring hs 9 12)) + (begin0 + (fun ip) + (close-input-port ip)) + (fail-k hs))) + +(define (url-path/no-slash url) + (define p (url-path url)) + (define rp (reverse p)) + (reverse + (match rp + [(list* (path/param "" _) rest) + rest] + [_ rp]))) + +(define (download-file! url file checksum + #:download-printf [download-printf #f] + #:use-cache? [use-cache? #t] + #: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) + (define (download!) + (when download-printf + (download-printf "Downloading ~a\n" (url->string url))) + (call-with-output-file file + (λ (op) + (call/input-url+200 + url + (λ (ip) (copy-port ip op)) + #:failure + (lambda (reply-s) + (pkg-error (~a "error downloading package\n" + " URL: ~a\n" + " server response: ~a") + (url->string url) + (read-line (open-input-string reply-s)))))))) + (cond + [(and checksum use-cache?) + (cache-file file + (list (url->string url) checksum) + (get-download-cache-dir) + download! + #:log-error-string (lambda (s) (log-pkg-error s)) + #:log-debug-string (lambda (s) (log-pkg-debug s)) + #:notify-cache-use (lambda (s) + (when download-printf + (download-printf "Using ~a for ~a\n" + s + (url->string url)))) + #:max-cache-files (get-download-cache-max-files) + #:max-cache-size (get-download-cache-max-bytes))] + [else (download!)]))) + +(define (clean-cache pkg-url checksum) + (when pkg-url + ;; Something failed after download, so remove cached file (if any): + (with-handlers ([exn:fail? void]) ; any error is logged already + (cache-remove (list (url->string pkg-url) checksum) + (get-download-cache-dir) + #:log-error-string (lambda (s) (log-pkg-error s)) + #:log-debug-string (lambda (s) (log-pkg-debug s)))))) diff --git a/racket/collects/pkg/private/get-info.rkt b/racket/collects/pkg/private/get-info.rkt new file mode 100644 index 0000000000..e3024a92f8 --- /dev/null +++ b/racket/collects/pkg/private/get-info.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require setup/getinfo + "print.rkt") + +;; Working with "info.rkt" files, typically (but not necessarily) +;; package-level "info.rkt" files. + +(provide make-metadata-namespace + get-pkg-info + get-metadata) + +(define (make-metadata-namespace) + (make-base-empty-namespace)) + +(define (get-pkg-info pkg-dir metadata-ns) + (with-handlers ([exn:fail? (λ (x) + (log-exn x "getting info") + #f)]) + (get-info/full pkg-dir + #:namespace metadata-ns + #:bootstrap? #t))) + +(define (get-metadata metadata-ns pkg-dir key get-default + #:checker [checker void]) + (define get-info (get-pkg-info pkg-dir metadata-ns)) + (define v + (if get-info + (get-info key get-default) + (get-default))) + (checker v) + v) + diff --git a/racket/collects/pkg/private/install.rkt b/racket/collects/pkg/private/install.rkt new file mode 100644 index 0000000000..40ce06c265 --- /dev/null +++ b/racket/collects/pkg/private/install.rkt @@ -0,0 +1,1024 @@ +#lang racket/base +(require racket/file + racket/path + racket/list + racket/format + racket/match + racket/string + racket/set + racket/function + openssl/sha1 + compiler/compilation-path + version/utils + setup/link + "../path.rkt" + "../name.rkt" + "stage.rkt" + "remove.rkt" + "desc.rkt" + "path.rkt" + "pkg-db.rkt" + "params.rkt" + "print.rkt" + "metadata.rkt" + "dep.rkt" + "get-info.rkt" + "dirs.rkt" + "collects.rkt" + "addl-installs.rkt") + +(provide pkg-install + pkg-update) + +(define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf) + (case type + [(file-url dir-url github) + (or given-checksum + (remote-package-checksum `(url ,pkg-source) download-printf pkg-name))] + [(file) + (define checksum-pth (format "~a.CHECKSUM" pkg-source)) + (or (and (file-exists? checksum-pth) + (file->string checksum-pth)) + (and (file-exists? pkg-source) + (call-with-input-file* pkg-source sha1)))] + [else given-checksum])) + +(define (disallow-package-path-overlaps pkg-name + pkg-path + path-pkg-cache + simultaneous-installs) + (define simple-pkg-path (simple-form-path pkg-path)) + (define (one-in-the-other? p1 p2) + (define pe (explode-path p1)) + (define e (explode-path p2)) + (if ((length e) . < . (length pe)) + (equal? (take pe (length e)) e) + (equal? (take e (length pe)) pe))) + ;; Check collects: + (for ([c (in-list (current-library-collection-paths))]) + (when (one-in-the-other? simple-pkg-path + (simple-form-path c)) + (pkg-error (~a "cannot link a directory that overlaps with a collection path\n" + " collection path: ~a\n" + " link path: ~a\n" + " as package: ~a") + c + pkg-path + pkg-name))) + ;; Check installed packages: + (for ([f (in-directory simple-pkg-path)]) + (define found-pkg (path->pkg f #:cache path-pkg-cache)) + (when (and found-pkg + (not (equal? found-pkg pkg-name))) + (pkg-error (~a "cannot link a directory that overlaps with existing packages\n" + " existing package: ~a\n" + " overlapping path: ~a\n" + " a package: ~a") + found-pkg + f + pkg-name))) + ;; Check simultaneous installs: + (for ([(other-pkg other-dir) (in-hash simultaneous-installs)]) + (unless (equal? other-pkg pkg-name) + (when (one-in-the-other? simple-pkg-path + (simple-form-path other-dir)) + (pkg-error (~a "cannot link directories that overlap for different packages\n" + " package: ~a\n" + " path: ~a\n" + " overlapping package: ~a\n" + " overlapping path: ~a") + pkg-name + pkg-path + other-pkg + other-dir))))) + + + +(define (ask question) + (let loop () + (printf question) + (printf " [Y/n/a/?] ") + (flush-output) + (match (string-trim (read-line (current-input-port) 'any)) + [(or "y" "Y" "") + 'yes] + [(or "n" "N") + 'no] + [(or "a" "A") + 'always-yes] + [x + (eprintf "Invalid answer: ~a\n" x) + (eprintf " Answer nothing or `y' or `Y' for \"yes\", `n' or `N' for \"no\", or\n") + (eprintf " `a' or `A' for \"yes for all\".\n") + (loop)]))) + +(define (format-deps update-deps) + (format-list (for/list ([ud (in-list update-deps)]) + (cond + [(pkg-desc? ud) + (pkg-desc-name ud)] + [(string? ud) + ud] + [else + (format "~a (have ~a, need ~a)" + (car ud) + (caddr ud) + (cadddr ud))])))) + +(define (install-packages + #:old-infos old-infos + #:old-descs old-descs + #:pre-succeed pre-succeed + #:dep-behavior dep-behavior + #:update-deps? update-deps? + #:update-implies? update-implies? + #:update-cache update-cache + #:updating? updating? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:skip-installed? skip-installed? + #:force? force? + #:all-platforms? all-platforms? + #:quiet? quiet? + #:from-command-line? from-command-line? + #:conversation conversation + #:strip strip-mode + #:force-strip? force-strip? + #:link-dirs? link-dirs? + #:local-docs-ok? local-docs-ok? + #:ai-cache ai-cache + descs) + (define download-printf (if quiet? void printf/flush)) + (define check-sums? (not ignore-checksums?)) + (define current-scope-db (read-pkg-db)) + (define all-db (merge-pkg-dbs)) + (define path-pkg-cache (make-hash)) + (define (install-package/outer infos desc info) + (match-define (pkg-desc pkg type orig-name given-checksum auto?) desc) + (match-define + (install-info pkg-name orig-pkg pkg-dir clean? checksum module-paths additional-installs) + info) + (define name? (eq? 'catalog (first orig-pkg))) + (define this-dep-behavior (or dep-behavior + (if name? + 'search-ask + 'fail))) + (define do-update-deps? + (and update-deps? + (member this-dep-behavior '(search-auto search-ask)))) + (define (clean!) + (when clean? + (delete-directory/files pkg-dir))) + (define (show-dependencies deps update? auto?) + (unless quiet? + (printf/flush "The following~a packages are listed as dependencies of ~a~a:~a\n" + (if update? " out-of-date" " uninstalled") + pkg-name + (if (or auto? (eq? conversation 'always-yes)) + (format "\nand they will be ~a~a" + (if auto? "automatically " "") + (if update? "updated" "installed")) + "") + (if update? + (format-deps deps) + (format-list deps))))) + (define simultaneous-installs + (for/hash ([i (in-list infos)]) + (values (install-info-name i) (install-info-directory i)))) + + (when (and (pair? orig-pkg) + (or (eq? (car orig-pkg) 'link) + (eq? (car orig-pkg) 'static-link))) + (disallow-package-path-overlaps pkg-name + pkg-dir + path-pkg-cache + simultaneous-installs)) + (cond + [(and (not updating?) + (hash-ref all-db pkg-name #f) + ;; Already installed, but can force if the install is for + ;; a wider scope: + (not (and (not (hash-ref current-scope-db pkg-name #f)) + force?))) + (define existing-pkg-info (hash-ref all-db pkg-name #f)) + (cond + [(and (pkg-info-auto? existing-pkg-info) + (not (pkg-desc-auto? desc)) + ;; Don't confuse a promotion request with a different-source install: + (equal? (pkg-info-orig-pkg existing-pkg-info) orig-pkg) + ;; Also, make sure it's installed in the scope that we're changing: + (hash-ref current-scope-db pkg-name #f)) + ;; promote an auto-installed package to a normally installed one + (lambda () + (unless quiet? + (download-printf "Promoting ~a from auto-installed to explicitly installed\n" pkg-name)) + (update-pkg-db! pkg-name (update-auto existing-pkg-info #f)))] + [else + ;; Fail --- already installed + (clean!) + (cond + [(not (hash-ref current-scope-db pkg-name #f)) + (pkg-error (~a "package is currently installed in a wider scope\n" + " package: ~a\n" + " installed scope: ~a\n" + " given scope: ~a") + pkg-name + (find-pkg-installation-scope pkg-name #:next? #t) + (current-pkg-scope))] + [(not (equal? (pkg-info-orig-pkg existing-pkg-info) orig-pkg)) + (pkg-error (~a "package is already installed from a different source\n" + " package: ~a\n" + " installed source: ~a\n" + " given source: ~a") + pkg-name + (pkg-info-orig-pkg existing-pkg-info) + orig-pkg)] + [else + (pkg-error "package is already installed\n package: ~a" + pkg-name)])])] + [(and + (not force?) + (for/or ([mp (in-set module-paths)]) + ;; In an installed collection? Try resolving the path: + (define r (with-handlers ([exn:fail:filesystem:missing-module? (lambda (x) #f)]) + ((current-module-name-resolver) mp #f #f #f))) + (define f (and r (resolved-module-path-name r))) + (when f + (unless (path? f) + (pkg-error "expected a filesystem path for a resolved module path: ~a" mp))) + ;; Check for source or compiled: + (cond + [(and f + (or (file-exists? f) + (file-exists? (path-replace-suffix f #".ss")) + (file-exists? (get-compilation-bytecode-file f)) + (file-exists? (get-compilation-bytecode-file (path-replace-suffix f #".ss")))) + (or (not updating?) + (not (equal? pkg-name (path->pkg f #:cache path-pkg-cache))))) + ;; This module is already installed + (cons (path->pkg f #:cache path-pkg-cache) mp)] + [else + ;; Compare with simultaneous installs + (for/or ([other-pkg-info (in-list infos)] + #:unless (eq? other-pkg-info info)) + (and (set-member? (install-info-module-paths other-pkg-info) mp) + (cons (install-info-name other-pkg-info) + mp)))]))) + => + (λ (conflicting-pkg*mp) + (clean!) + (match-define (cons conflicting-pkg mp) conflicting-pkg*mp) + (if conflicting-pkg + (pkg-error (~a "packages ~aconflict\n" + " package: ~a\n" + " package: ~a\n" + " module path: ~s") + (if (equal? conflicting-pkg pkg-name) + "in different scopes " + "") + pkg conflicting-pkg (pretty-module-path mp)) + (pkg-error (~a "package conflicts with existing installed module\n" + " package: ~a\n" + " module path: ~s") + pkg (pretty-module-path mp))))] + [(and + (not force?) + (for/or ([ai (in-set additional-installs)]) + ;; Check for source or compiled: + (cond + ;; If `local-docs-ok?`, exempt doc collisions for user-scope install, since + ;; user-scope documentation is rendered within the package: + [(and local-docs-ok? + (eq? (car ai) 'doc) + (eq? (current-pkg-scope) 'user)) + #f] + [(set-member? (get-additional-installed (car ai) + simultaneous-installs + ai-cache + metadata-ns + path-pkg-cache) + ai) + ;; This item is already installed + (cons #f ai)] + [else + ;; Compare with simultaneous installs + (for/or ([other-pkg-info (in-list infos)] + #:unless (eq? other-pkg-info info)) + (and (set-member? (install-info-additional-installs other-pkg-info) ai) + (cons (install-info-name other-pkg-info) + ai)))]))) + => + (λ (conflicting-pkg*ai) + (clean!) + (match-define (cons conflicting-pkg ai) conflicting-pkg*ai) + (if conflicting-pkg + (pkg-error (~a "packages ~aconflict\n" + " package: ~a\n" + " package: ~a\n" + " item category: ~a\n" + " item name: ~s") + (if (equal? conflicting-pkg pkg-name) + "in different scopes " + "") + pkg conflicting-pkg + (car ai) + (cdr ai)) + (pkg-error (~a "package conflicts with existing installed item\n" + " package: ~a\n" + " item category: ~a\n" + " item name: ~s") + pkg + (car ai) + (cdr ai))))] + [(and + (not (eq? dep-behavior 'force)) + (let () + (define deps (get-all-deps metadata-ns pkg-dir)) + (define unsatisfied-deps + (map dependency->source + (filter-not (λ (dep) + (define name (dependency->name dep)) + (or (equal? name "racket") + (not (or all-platforms? + (dependency-this-platform? dep))) + (hash-ref simultaneous-installs name #f) + (hash-has-key? all-db name))) + deps))) + (and (not (empty? unsatisfied-deps)) + unsatisfied-deps))) + => + (λ (unsatisfied-deps) + (match this-dep-behavior + ['fail + (clean!) + (pkg-error (~a "missing dependencies" + (if from-command-line? + (~a ";\n" + " specify `--deps search-auto' to install them, or\n" + " specify `--deps search-ask' to be asked about installing them") + "") + "\n" + " for package: ~a\n" + " missing packages:~a") + pkg + (format-list unsatisfied-deps))] + ['search-auto + ;; (show-dependencies unsatisfied-deps #f #t) + (raise (vector updating? infos pkg-name unsatisfied-deps void 'always-yes))] + ['search-ask + (show-dependencies unsatisfied-deps #f #f) + (case (if (eq? conversation 'always-yes) + 'always-yes + (ask "Would you like to install these dependencies?")) + [(yes) + (raise (vector updating? infos pkg-name unsatisfied-deps void 'again))] + [(always-yes) + (raise (vector updating? infos pkg-name unsatisfied-deps void 'always-yes))] + [(no) + (clean!) + (pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))])]))] + [(and + (or do-update-deps? + update-implies?) + (let () + (define-values (run-deps build-deps) (get-all-deps* metadata-ns pkg-dir)) + (define deps (append run-deps build-deps)) + (define implies (list->set + (append + (get-all-implies metadata-ns pkg-dir run-deps) + (get-all-update-implies metadata-ns pkg-dir deps)))) + (define update-pkgs + (append-map (λ (dep) + (define name (dependency->name dep)) + (define this-platform? (or all-platforms? + (dependency-this-platform? dep))) + (or (and this-platform? + (or do-update-deps? + (set-member? implies name)) + (not (hash-ref simultaneous-installs name #f)) + ((packages-to-update download-printf current-scope-db + #:must-update? #f + #:deps? do-update-deps? + #:implies? update-implies? + #:update-cache update-cache + #:namespace metadata-ns + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + name)) + null)) + deps)) + (and (not (empty? update-pkgs)) + update-pkgs + (let () + (define (continue conversation) + (raise (vector #t infos pkg-name update-pkgs + (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) update-pkgs)) + conversation))) + (match (if (andmap (lambda (dep) (set-member? implies (pkg-desc-name dep))) + update-pkgs) + 'search-auto + this-dep-behavior) + ['search-auto + (show-dependencies update-pkgs #t #t) + (continue conversation)] + ['search-ask + (show-dependencies update-pkgs #t #f) + (case (if (eq? conversation 'always-yes) + 'always-yes + (ask "Would you like to update these dependencies?")) + [(yes) + (continue 'again)] + [(always-yes) + (continue 'always-yes)] + [(no) + ;; Don't fail --- just skip update + #f])]))))) + (error "internal error: should have raised an exception")] + [(and + (not (eq? dep-behavior 'force)) + (let () + (define deps (get-all-deps metadata-ns pkg-dir)) + (define update-deps + (filter-map (λ (dep) + (define name (dependency->name dep)) + (define req-vers (dependency->version dep)) + (define this-platform? (or all-platforms? + (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))) + ;; 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) + (define db current-scope-db) + (let ([to-update (append-map (packages-to-update download-printf db + #:deps? update-deps? + #:implies? update-implies? + #:update-cache update-cache + #:namespace metadata-ns + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + update-pkgs)]) + (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update)))) + (match this-dep-behavior + ['fail + (clean!) + (report-mismatch update-deps)] + ['search-auto + (show-dependencies update-deps #t #t) + (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'always-yes))] + ['search-ask + (show-dependencies update-deps #t #f) + (case (if (eq? conversation 'always-yes) + 'always-yes + (ask "Would you like to update these dependencies?")) + [(yes) + (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'again))] + [(always-yes) + (raise (vector #t infos pkg-name update-pkgs (make-pre-succeed) 'always-yes))] + [(no) + (clean!) + (report-mismatch update-deps)])]))] + [else + (λ () + (when updating? + (download-printf "Re-installing ~a\n" pkg-name)) + (define final-pkg-dir + (cond + [clean? + (define final-pkg-dir (select-package-directory + (build-path (pkg-installed-dir) pkg-name))) + (make-parent-directory* final-pkg-dir) + (copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t) + (clean!) + final-pkg-dir] + [else + pkg-dir])) + (define single-collect (pkg-single-collection final-pkg-dir + #:name pkg-name + #:namespace post-metadata-ns)) + (log-pkg-debug "creating ~alink to ~e" + (if single-collect "single-collection " "") + final-pkg-dir) + (define scope (current-pkg-scope)) + (links final-pkg-dir + #:name single-collect + #:user? (not (or (eq? 'installation scope) + (path? scope))) + #:file (scope->links-file scope) + #:root? (not single-collect) + #:static-root? (and (pair? orig-pkg) + (eq? 'static-link (car orig-pkg)))) + (define alt-dir-name + ;; If we had to pick an alternate dir name, then record it: + (let-values ([(base name dir?) (split-path final-pkg-dir)]) + (and (regexp-match? #rx"[+]" name) + (path->string name)))) + (define this-pkg-info + (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name)) + (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) + #:given-checksum (pkg-desc-checksum v) + #:use-cache? use-cache? + check-sums? download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip? + #:link-dirs? link-dirs?))) + ;; For the top-level call, we need to double-check that all provided packages + ;; were distinct: + (for/fold ([ht (hash)]) ([i (in-list infos)] + [desc (in-list descs)]) + (define name (install-info-name i)) + (when (hash-ref ht name #f) + (pkg-error (~a "given package sources have the same package name\n" + " package name: ~a\n" + " package source: ~a\n" + " package source: ~a") + name + (pkg-desc-source (hash-ref ht name #f)) + (pkg-desc-source desc))) + (hash-set ht name desc)) + + (define all-descs (append old-descs descs)) + (define all-infos (append old-infos infos)) + + (define do-its + (map (curry install-package/outer all-infos) + all-descs + all-infos)) + (pre-succeed) + + (define post-metadata-ns (make-metadata-namespace)) + (for-each (λ (t) (t)) do-its) + + (define (is-promote? info) + ;; if the package name is in `current-scope-db', we must + ;; be simply promiting the package, and so it's + ;; already set up: + (and (hash-ref current-scope-db (install-info-name info) #f) #t)) + + (define setup-collects + (let ([db (read-pkg-db)]) + (get-setup-collects ((if updating? + (make-close-over-depending (read-pkg-db) + post-metadata-ns + all-platforms?) + values) + (map install-info-name + (if updating? + all-infos + (filter-not is-promote? all-infos)))) + db + post-metadata-ns))) + + (cond + [(or (null? do-its) + (and (not updating?) (andmap is-promote? all-infos))) + ;; No actions, so no setup: + 'skip] + [else + setup-collects])) + +(define ((make-close-over-depending db metadata-ns all-platforms?) l) + (define setup-pkgs (list->set l)) + (define empty-set (set)) + (define rev-pkg-deps + (for/fold ([rev (hash)]) ([pkg-name (in-hash-keys db)]) + (for/fold ([rev rev]) ([dep (in-list ((package-dependencies metadata-ns db all-platforms?) + pkg-name))]) + (hash-update rev dep (lambda (v) (set-add v pkg-name)) empty-set)))) + (let loop ([check setup-pkgs] [setup-pkgs setup-pkgs]) + ;; Find all packages that depend on a package in `check': + (define new-check + (set-subtract (for/fold ([new-check (set)]) ([pkg (in-set check)]) + (set-union new-check + (hash-ref rev-pkg-deps pkg empty-set))) + setup-pkgs)) + (cond + [(set-empty? new-check) + ;; found fixed point: + (set->list setup-pkgs)] + [else + ;; more packages to setup and check: + (loop new-check + (set-union setup-pkgs new-check))]))) + +(define (select-package-directory dir #:counter [counter 0]) + (define full-dir (if (zero? counter) + dir + (let-values ([(base name dir?) (split-path dir)]) + (define new-name (bytes->path + (bytes-append (path->bytes name) + (string->bytes/utf-8 + (~a "+" counter))))) + (if (path? base) + (build-path base new-name) + new-name)))) + (cond + [(directory-exists? full-dir) + ;; If the directory exists, assume that we'd like to replace it. + ;; Maybe the directory couldn't be deleted when a package was + ;; uninstalled, and maybe it will work now (because some process + ;; has completed on Windows or some other filesystem with locks). + (with-handlers ([exn:fail:filesystem? + (lambda (exn) + (log-pkg-warning "error deleting old directory: ~a" + (exn-message exn)) + (select-package-directory dir #:counter (add1 counter)))]) + (delete-directory/files full-dir) + ;; delete succeeded: + full-dir)] + [else + ;; all clear to use the selected name: + full-dir])) + +(define (snoc l x) + (append l (list x))) + +(define (pkg-install descs + #:old-infos [old-infos empty] + #:old-auto+pkgs [old-descs empty] + #:all-platforms? [all-platforms? #f] + #:force? [force #f] + #:ignore-checksums? [ignore-checksums? #f] + #:strict-doc-conflicts? [strict-doc-conflicts? #f] + #:use-cache? [use-cache? #t] + #:skip-installed? [skip-installed? #f] + #:pre-succeed [pre-succeed void] + #:dep-behavior [dep-behavior #f] + #:update-deps? [update-deps? #f] + #:update-implies? [update-implies? #t] + #:update-cache [update-cache (make-hash)] + #:updating? [updating? #f] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f] + #:conversation [conversation #f] + #:strip [strip-mode #f] + #:force-strip? [force-strip? #f] + #:link-dirs? [link-dirs? #f] + #:summary-deps [summary-deps empty]) + (define new-descs + (remove-duplicates + (if (not skip-installed?) + descs + (let ([db (read-pkg-db)]) + (filter (lambda (d) + (define pkg-name + (or (pkg-desc-name d) + (package-source->name (pkg-desc-source d) + (pkg-desc-type d)))) + (define i (hash-ref db pkg-name #f)) + (or (not i) (pkg-info-auto? i))) + descs))) + pkg-desc=?)) + (with-handlers* ([vector? + (match-lambda + [(vector updating? new-infos dep-pkg deps more-pre-succeed conv) + (pkg-install + #:summary-deps (snoc summary-deps (vector dep-pkg deps)) + #:old-infos new-infos + #:old-auto+pkgs (append old-descs new-descs) + #:all-platforms? all-platforms? + #:force? force + #:ignore-checksums? ignore-checksums? + #:strict-doc-conflicts? strict-doc-conflicts? + #:use-cache? use-cache? + #:dep-behavior dep-behavior + #:update-deps? update-deps? + #:update-implies? update-implies? + #:update-cache update-cache + #:pre-succeed (lambda () (pre-succeed) (more-pre-succeed)) + #:updating? updating? + #:conversation conv + #:strip strip-mode + #:force-strip? force-strip? + (for/list ([dep (in-list deps)]) + (if (pkg-desc? dep) + dep + (pkg-desc dep #f #f #f #t))))])]) + (begin0 + (install-packages + #:old-infos old-infos + #:old-descs old-descs + #:all-platforms? all-platforms? + #:force? force + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:skip-installed? skip-installed? + #:dep-behavior dep-behavior + #:update-deps? update-deps? + #:update-implies? update-implies? + #:update-cache update-cache + #:pre-succeed pre-succeed + #:updating? updating? + #:quiet? quiet? + #:from-command-line? from-command-line? + #:conversation conversation + #:strip strip-mode + #:force-strip? force-strip? + #:link-dirs? link-dirs? + #:local-docs-ok? (not strict-doc-conflicts?) + #:ai-cache (box #f) + new-descs) + (unless (empty? summary-deps) + (unless quiet? + (printf/flush "The following~a packages were listed as dependencies~a:~a\n" + (if updating? " out-of-date" " uninstalled") + (format "\nand they were ~a~a" + (if (eq? dep-behavior 'search-auto) "automatically " "") + (if updating? "updated" "installed")) + (string-append* + (for/list ([p*ds (in-list summary-deps)]) + (match-define (vector n ds) p*ds) + (format "\n dependencies of ~a:~a" + n + (if updating? + (format-deps ds) + (format-list ds))))))))))) + +;; Determine packages to update, starting with `pkg-name'. If `pkg-name' +;; needs to be updated, return it in a list. Otherwise, if `deps?', +;; then return a list of dependencies that need to be updated. +;; (If a package needs to be updated, wait until the update +;; has been inspected for further dependencies.) +;; If `must-installed?', then complain if the package is not +;; installed inthe current scope. +;; If `must-update?', then complain if the package is not +;; updatable. +;; The `update-cache' argument is used to cache which packages +;; are already being updated and downloaded checksums. +(define ((packages-to-update download-printf db + #:must-installed? [must-installed? #t] + #:must-update? [must-update? #t] + #:deps? deps? + #:implies? implies? + #:namespace metadata-ns + #:update-cache update-cache + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + pkg-name) + (cond + [(pkg-desc? pkg-name) + ;; Infer the package-source type and name: + (define-values (inferred-name type) (package-source->name+type + (pkg-desc-source pkg-name) + (pkg-desc-type pkg-name) + #:must-infer-name? (not (pkg-desc-name pkg-name)) + #:complain complain-about-source)) + (define name (or (pkg-desc-name pkg-name) + inferred-name)) + ;; Check that the package is installed, and get current checksum: + (define info (package-info name #:db db)) + (define new-checksum (checksum-for-pkg-source (pkg-desc-source pkg-name) + type + name + (pkg-desc-checksum pkg-name) + download-printf)) + (unless (or ignore-checksums? (not (pkg-desc-checksum pkg-name))) + (unless (equal? (pkg-desc-checksum pkg-name) new-checksum) + (pkg-error (~a "incorrect checksum on package\n" + " package source: ~a\n" + " expected: ~e\n" + " got: ~e") + (pkg-desc-source pkg-name) + (pkg-desc-checksum pkg-name) + new-checksum))) + (if (or (not (equal? (pkg-info-checksum info) + new-checksum)) + ;; No checksum available => always update + (not new-checksum)) + ;; Update: + (begin + (hash-set! update-cache (pkg-desc-source pkg-name) #t) + (list (pkg-desc (pkg-desc-source pkg-name) + (pkg-desc-type pkg-name) + name + (pkg-desc-checksum pkg-name) + (pkg-desc-auto? pkg-name)))) + ;; No update needed, but maybe check dependencies: + (if (or deps? + implies?) + ((packages-to-update download-printf db + #:must-update? #f + #:deps? deps? + #:implies? implies? + #:update-cache update-cache + #:namespace metadata-ns + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + name) + null))] + [(eq? #t (hash-ref update-cache pkg-name #f)) + ;; package is already being updated + null] + ;; A string indicates that package source that should be + ;; looked up in the installed packages to get the old source + ;; for getting the checksum: + [(package-info pkg-name #:db db must-update?) + => + (lambda (m) + (match-define (pkg-info orig-pkg checksum auto?) m) + (match orig-pkg + [`(,(or 'link 'static-link) ,orig-pkg-dir) + (if must-update? + (pkg-error (~a "cannot update linked packages~a\n" + " package name: ~a\n" + " package source: ~a") + (if from-command-line? + " without `--link'" + " without new link") + pkg-name + (normalize-path + (path->complete-path orig-pkg-dir (pkg-installed-dir)))) + null)] + [`(dir ,_) + (if must-update? + (pkg-error (~a "cannot update packages installed locally;\n" + " package was installed via a local directory\n" + " package name: ~a") + pkg-name) + null)] + [`(file ,_) + (if must-update? + (pkg-error (~a "cannot update packages installed locally;\n" + " package was installed via a local file\n" + " package name: ~a") + pkg-name) + null)] + [`(,_ ,orig-pkg-source) + (define new-checksum + (or (hash-ref update-cache pkg-name #f) + (remote-package-checksum orig-pkg download-printf pkg-name))) + ;; Record downloaded checksum: + (hash-set! update-cache pkg-name new-checksum) + (or (and new-checksum + (not (equal? checksum new-checksum)) + (begin + ;; Update it: + (hash-set! update-cache pkg-name #t) + ;; Flush cache of downloaded checksums, in case + ;; there was a race between our checkig and updates on + ;; the catalog server: + (clear-checksums-in-cache! update-cache) + ;; FIXME: the type shouldn't be #f here; it should be + ;; preseved from install time: + (list (pkg-desc orig-pkg-source #f pkg-name #f auto?)))) + (if (or deps? implies?) + ;; Check dependencies + (append-map + (packages-to-update download-printf db + #:must-update? #f + #:deps? deps? + #:implies? implies? + #:update-cache update-cache + #:namespace metadata-ns + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + ((package-dependencies metadata-ns db all-platforms? + #:only-implies? (not deps?)) + pkg-name)) + null))]))] + [else null])) + +(define (pkg-update in-pkgs + #:all? [all? #f] + #:dep-behavior [dep-behavior #f] + #:all-platforms? [all-platforms? #f] + #:force? [force? #f] + #:ignore-checksums? [ignore-checksums? #f] + #:strict-doc-conflicts? [strict-doc-conflicts? #f] + #:use-cache? [use-cache? #t] + #:update-deps? [update-deps? #f] + #:update-implies? [update-implies? #t] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f] + #:strip [strip-mode #f] + #:force-strip? [force-strip? #f] + #:link-dirs? [link-dirs? #f]) + (define download-printf (if quiet? void printf)) + (define metadata-ns (make-metadata-namespace)) + (define db (read-pkg-db)) + (define all-mode? (and all? (empty? in-pkgs))) + (define pkgs (cond + [all-mode? (hash-keys db)] + [else in-pkgs])) + (define update-cache (make-hash)) + (define to-update (append-map (packages-to-update download-printf db + #:must-update? (not all-mode?) + #:deps? (or update-deps? + all-mode?) ; avoid races + #:implies? update-implies? + #:update-cache update-cache + #:namespace metadata-ns + #:all-platforms? all-platforms? + #:ignore-checksums? ignore-checksums? + #:use-cache? use-cache? + #:from-command-line? from-command-line?) + pkgs)) + (cond + [(empty? pkgs) + (unless quiet? + (printf/flush (~a "No packages given to update" + (if from-command-line? + ";\n use `--all' to update all packages" + "") + "\n"))) + 'skip] + [(empty? to-update) + (unless quiet? + (printf/flush "No updates available\n")) + 'skip] + [else + (unless quiet? + (printf "Updating:\n") + (for ([u (in-list to-update)]) + (printf " ~a\n" (pkg-desc-name u))) + (flush-output)) + (pkg-install + #:updating? #t + #:pre-succeed (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update)) + #:dep-behavior dep-behavior + #:update-deps? update-deps? + #:update-implies? update-implies? + #:update-cache update-cache + #:quiet? quiet? + #:from-command-line? from-command-line? + #:strip strip-mode + #:force-strip? force-strip? + #:all-platforms? all-platforms? + #:force? force? + #:ignore-checksums? ignore-checksums? + #:strict-doc-conflicts? strict-doc-conflicts? + #:use-cache? use-cache? + #:link-dirs? link-dirs? + to-update)])) + +;; ---------------------------------------- + +(define (clear-checksums-in-cache! update-cache) + (define l (for/list ([(k v) (in-hash update-cache)] + #:when (string? v)) + k)) + (for ([k (in-list l)]) (hash-remove! update-cache k))) diff --git a/racket/collects/pkg/private/lock.rkt b/racket/collects/pkg/private/lock.rkt new file mode 100644 index 0000000000..20e0f75462 --- /dev/null +++ b/racket/collects/pkg/private/lock.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require racket/file + racket/format + "params.rkt" + "print.rkt" + "dirs.rkt" + "path.rkt") + +(provide pkg-lock-held + with-pkg-lock + with-pkg-lock/read-only + ;; Checks that the lock is held: + write-file-hash!) + +(define pkg-lock-held (make-parameter #f)) +(define pkg-lock-scope (make-parameter #f)) + +;; Call `t' with lock held for the current scope. The intent is that +;; `t' reads and writes package information in the curent scope. It +;; may also *read* package information for wider package scopes +;; without a further lock --- which is questionable, but modification +;; of a shared scope while others are running can create trouble, +;; anyway. +(define (with-pkg-lock* read-only? t) + (define mode (if read-only? 'shared 'exclusive)) + (define held-mode (pkg-lock-held)) + (define now-scope (current-pkg-scope)) + (define held-scope (pkg-lock-scope)) + (when (and held-scope + (not (eq? held-scope now-scope))) + (pkg-error "lock mismatch\n held scope: ~a\n requested scope: ~a" + held-scope + now-scope)) + (if (or (eq? mode held-mode) + (eq? 'exclusive held-mode)) + (t) + (let ([d (pkg-dir #f)]) + (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] + [pkg-lock-scope now-scope] + [current-no-pkg-db #f]) + (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 now-scope]) + (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 (write-file-hash! file new-db) + (unless (eq? (pkg-lock-held) 'exclusive) + (pkg-error "attempt to write package database without write lock")) + (make-parent-directory* file) + (call-with-atomic-output-file + file + (λ (o tmp-path) (write new-db o) (newline o)))) diff --git a/racket/collects/pkg/private/metadata.rkt b/racket/collects/pkg/private/metadata.rkt new file mode 100644 index 0000000000..f364d6244c --- /dev/null +++ b/racket/collects/pkg/private/metadata.rkt @@ -0,0 +1,120 @@ +#lang racket/base +(require version/utils + racket/format + racket/list + racket/set + setup/collection-name + "../name.rkt" + "get-info.rkt" + "print.rkt" + "dep.rkt") + +;; Extracting information from a package's "info.rkt" file. + +(provide (all-defined-out)) + +(define ((check-dependencies which) 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 `" which "' specification\n" + " specification: ~e") + deps))) + +(define (get-all-deps* metadata-ns pkg-dir) + (values + (get-metadata metadata-ns pkg-dir + 'deps (lambda () empty) + #:checker (check-dependencies 'deps)) + (get-metadata metadata-ns pkg-dir + 'build-deps (lambda () empty) + #:checker (check-dependencies 'build-deps)))) + +(define (get-all-deps metadata-ns pkg-dir) + (define-values (deps build-deps) (get-all-deps* metadata-ns pkg-dir)) + (append deps build-deps)) + +(define (get-all-deps-subset key metadata-ns pkg-dir deps) + (get-metadata metadata-ns pkg-dir + key (lambda () empty) + #:checker (lambda (l) + (unless (null? l) + (define deps-set (list->set + (map dependency->name deps))) + (unless (and (list? l) + (andmap (lambda (v) + (or (string? v) + (eq? v 'core))) + l)) + (pkg-error (~a "invalid `~a' specification\n" + " specification: ~e") + key + l)) + (unless (andmap (lambda (i) + (or (eq? i 'core) + (set-member? deps-set i))) + l) + (pkg-error (~a "`~a' is not a subset of dependencies\n" + " specification: ~e") + key + l)))))) + +(define (get-all-implies metadata-ns pkg-dir deps) + (get-all-deps-subset 'implies metadata-ns pkg-dir deps)) + +(define (get-all-update-implies metadata-ns pkg-dir deps) + (get-all-deps-subset 'update-implies metadata-ns pkg-dir deps)) + +(define (pkg-single-collection dir + #:name [pkg-name (let-values ([(base name dir?) (split-path dir)]) + (path-element->string name))] + #:namespace [metadata-ns (make-metadata-namespace)]) + (define i (get-pkg-info dir metadata-ns)) + (if (not i) + pkg-name + (let ([s (i 'collection (lambda () 'use-pkg-name))]) + (unless (or (collection-name-element? s) + (eq? s 'multi) + (eq? s 'use-pkg-name)) + (log-error (format (~a "bad `collection' definition in \"info.rkt\";\n" + " definition will be ignored\n" + " path: ~a\n" + " found: ~e\n" + " expected: (or/c collection-name-element? 'multi 'use-pkg-name)") + (build-path dir "info.rkt") + s))) + (or (and (collection-name-element? s) + s) + (and (eq? s 'use-pkg-name) + pkg-name))))) diff --git a/racket/collects/pkg/private/migrate.rkt b/racket/collects/pkg/private/migrate.rkt new file mode 100644 index 0000000000..20211a44f2 --- /dev/null +++ b/racket/collects/pkg/private/migrate.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require racket/match + "../path.rkt" + "config.rkt" + "lock.rkt" + "pkg-db.rkt" + "desc.rkt" + "params.rkt" + "install.rkt") + +(provide pkg-migrate) + +(define (pkg-migrate from-version + #:all-platforms? [all-platforms? #f] + #:force? [force? #f] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #f] + #:ignore-checksums? [ignore-checksums? #f] + #:strict-doc-conflicts? [strict-doc-conflicts? #f] + #:use-cache? [use-cache? #t] + #:dep-behavior [dep-behavior #f] + #:strip [strip-mode #f] + #:force-strip? [force-strip? #f]) + (define from-db + (parameterize ([current-pkg-scope-version from-version]) + (installed-pkg-table #:scope 'user))) + (define to-install + (sort + (for/list ([(name info) (in-hash from-db)] + #:unless (pkg-info-auto? info)) + (define-values (source type) + (match (pkg-info-orig-pkg info) + [(list 'catalog name) (values name 'name)] + [(list 'url url) (values url #f)] + [(list 'link path) (values path 'link)] + [(list 'static-link path) (values path 'static-link)])) + (pkg-desc source type name #f #f)) + stringmodule-paths + directory->module-paths) + +(define (pkg-directory->module-paths dir pkg-name + #:namespace [metadata-ns (make-metadata-namespace)]) + (set->list (directory->module-paths dir pkg-name metadata-ns))) + +(define (directory->module-paths dir pkg-name metadata-ns) + (define dummy (build-path dir "dummy.rkt")) + (define compiled (string->path-element "compiled")) + (define single-collect (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns)) + (define (try-path s f) + (define mp + `(lib ,(apply ~a + #:separator "/" + (let ([l (map path-element->string + (explode-path f))]) + (if single-collect + (if (eq? 'relative (car l)) + (cons single-collect (cdr l)) + (cons single-collect l)) + l))))) + (if (module-path? mp) + (set-add s (collapse-module-path mp dummy)) + s)) + (parameterize ([current-directory dir]) + (let loop ([s (set)] [f 'init] [check-zo? #f]) + (cond + [(eq? f 'init) + (for/fold ([s s]) ([f (directory-list)]) + (loop s f check-zo?))] + [(directory-exists? f) + ;; Count ".zo" files toward the set of module paths only + ;; if an "info.rkt" in an enclosing directory says to + ;; assume virtual sources. Otherwise, the ".zo" file will + ;; be discarded by `raco setup'. + (define sub-check-zo? + (or check-zo? + (let ([i (get-pkg-info f metadata-ns)]) + (and i + (i 'assume-virtual-sources (lambda () #f)))))) + (for/fold ([s s]) ([f (directory-list f #:build? #t)]) + (loop s f sub-check-zo?))] + [(not (file-exists? f)) s] + [else + (define-values (base name dir?) (split-path f)) + (cond + [(and (eq? 'relative base) (not single-collect)) s] + [else + (define bstr (path-element->bytes name)) + (cond + [(or (equal? #"info.rkt" bstr) + (equal? #"info.ss" bstr)) + ;; don't count "info.rkt" as a conflict, because + ;; splices may need their own "info.rkt"s, and + ;; `raco setup' can handle that + s] + [(regexp-match? #rx#"[.](?:rkt|ss|scrbl)$" bstr) + (try-path s f)] + [(and check-zo? + (regexp-match? #rx#"_(?:rkt|ss|scrbl)[.]zo$" (path-element->bytes name))) + (define-values (dir-base dir-name dir?) (split-path base)) + (cond + [(eq? 'relative dir-base) s] + [(equal? dir-name compiled) + (define bstr2 (regexp-replace + #rx#"_(?:rkt|ss|scrbl)[.]zo$" + (path-element->bytes name) + #".rkt")) + (if (equal? #"info.rkt" bstr2) + s + (try-path s (build-path dir-base + (bytes->path-element + bstr2))))] + [else s])] + [else s])])])))) + diff --git a/racket/collects/pkg/private/params.rkt b/racket/collects/pkg/private/params.rkt new file mode 100644 index 0000000000..e55b294907 --- /dev/null +++ b/racket/collects/pkg/private/params.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket/path + setup/dirs) + +(provide (all-defined-out)) + +(define current-pkg-scope + (make-parameter 'user (lambda (p) + (if (path? p) + (simple-form-path p) + p)))) +(define current-pkg-scope-version + (make-parameter (get-installation-name))) +(define current-pkg-lookup-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 current-pkg-download-cache-dir + (make-parameter #f)) +(define current-pkg-download-cache-max-files + (make-parameter #f)) +(define current-pkg-download-cache-max-bytes + (make-parameter #f)) + diff --git a/racket/collects/pkg/private/path.rkt b/racket/collects/pkg/private/path.rkt new file mode 100644 index 0000000000..af12c2ce67 --- /dev/null +++ b/racket/collects/pkg/private/path.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require racket/path + racket/file + racket/list + racket/function) + +(provide (all-defined-out)) + +(define (make-parent-directory* p) + (define parent (path-only p)) + (make-directory* parent)) + +(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 (pretty-module-path 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 (lift-directory-content pkg-dir path) + (define orig-sub (let ([s (car path)]) + (if (string? s) + (string->path s) + s))) + ;; Delete everything except `orig-sub`: + (for ([f (in-list (directory-list pkg-dir))]) + (unless (equal? f orig-sub) + (delete-directory/files (build-path pkg-dir f)))) + ;; Get list of files and directories to move: + (define sub-l (directory-list (apply build-path pkg-dir path))) + ;; Make sure `sub` doesn't match a name we want to move here: + (define sub + (let loop ([sub orig-sub] [i 0]) + (cond + [(member sub sub-l) + ;; pick a new name: + (loop (string->path (format "sub~a" i)) (add1 i))] + [(not (equal? sub orig-sub)) + (rename-file-or-directory (build-path pkg-dir orig-sub) + (build-path pkg-dir sub)) + sub] + [else sub]))) + ;; Move content of `sub` out: + (define sub-path (apply build-path (cons sub (cdr path)))) + (for ([f (in-list sub-l)]) + (rename-file-or-directory (build-path pkg-dir sub-path f) + (build-path pkg-dir f))) + ;; Remove directory that we moved files out of: + (delete-directory/files (build-path pkg-dir sub))) + +(define (remove-extra-directory-layer pkg-dir) + ;; Treat a single directory produced in `pkg-dir` + ;; as having the content of the package, instead of + ;; being included itself in the package content. + (define l (directory-list pkg-dir)) + (when (= 1 (length l)) + (define orig-sub (car l)) + (when (directory-exists? (build-path pkg-dir orig-sub)) + (lift-directory-content pkg-dir (list orig-sub))))) diff --git a/racket/collects/pkg/private/pkg-db.rkt b/racket/collects/pkg/private/pkg-db.rkt new file mode 100644 index 0000000000..37ee2976a5 --- /dev/null +++ b/racket/collects/pkg/private/pkg-db.rkt @@ -0,0 +1,220 @@ +#lang racket/base +(require setup/dirs + racket/format + racket/match + racket/set + "../path.rkt" + "params.rkt" + "lock.rkt" + "print.rkt" + "dirs.rkt" + "config.rkt") + +;; Read and writing the database of installed packages. + +(provide read-pkg-db + merge-pkg-dbs + find-pkg-installation-scope + package-info + update-pkg-db! + remove-from-pkg-db! + pkg-directory + pkg-directory* + pkg-directory** + make-pkg-info + update-auto + scope->links-file + installed-pkg-table + installed-pkg-names) + +(define (read-pkg-db) + (unless (pkg-lock-held) + (pkg-error "attempt to read package database without lock")) + (define scope (current-pkg-scope)) + (if (eq? (current-no-pkg-db) scope) + #hash() + (read-pkgs-db scope (current-pkg-scope-version)))) + +;; read all packages in this scope or wider +(define (merge-pkg-dbs [scope (current-pkg-scope)]) + (define (merge-next-pkg-dbs scope) + (parameterize ([current-pkg-scope scope]) + (merge-pkg-dbs scope))) + (if (path? scope) + (read-pkg-db) + (case scope + [(installation) + (for*/hash ([dir (in-list (get-pkgs-search-dirs))] + [(k v) (read-pkgs-db dir)]) + (values k v))] + [(user) + (define db (read-pkgs-db 'user (current-pkg-scope-version))) + (for/fold ([ht (merge-next-pkg-dbs 'installation)]) ([(k v) (in-hash db)]) + (hash-set ht k v))]))) + +;; Finds the scope, in which `pkg-name' is installed; returns 'dir, +;; 'installation, a path, or #f (where #f means "not installed"). If +;; `next?' is true, search only scopes wider than the current one. +(define (find-pkg-installation-scope pkg-name #:next? [next? #f]) + (case (current-pkg-scope) + [(user) + (or (and (not next?) + (hash-ref (read-pkg-db) pkg-name #f) + 'user) + (parameterize ([current-pkg-scope 'installation]) + (find-pkg-installation-scope pkg-name)))] + [(installation) + (or (and (not next?) + (hash-ref (read-pkg-db) pkg-name #f) + 'installation) + (for/or ([dir (in-list (get-pkgs-search-dirs))]) + (and (hash-ref (read-pkgs-db dir) pkg-name #f) + dir)))] + [else + (and (not next?) + (and (hash-ref (read-pkgs-db (current-pkg-scope)) pkg-name #f) + (current-pkg-scope)))])) + +(define (package-info pkg-name [fail? #t] #:db [given-db #f]) + (define db (or given-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)])) + +;; prints an error for packages that are not installed +;; pkg-name db -> void +(define (pkg-not-installed pkg-name db) + ;; This may read narrower package scopes without holding the + ;; lock, but maybe that's ok for mere error reporting: + (define s (parameterize ([current-pkg-scope 'user]) + (find-pkg-installation-scope pkg-name))) + + (define not-installed-msg + (cond [s "package installed in a different scope"] + [else "package not currently installed"])) + + (apply pkg-error (~a not-installed-msg + "\n package: ~a" + "\n current scope: ~a" + (if s + "\n installed in scope: ~a" + "") + ;; Probably too much information: + #; + "\n packages in current scope:~a") + (append + (list + pkg-name + (current-scope->string)) + (if s (list s) null) + #; + (list + (format-list (hash-keys db)))))) + +;; return the current scope as a string +(define (current-scope->string) + (define scope (current-pkg-scope)) + (cond + [(path? scope) (path->string scope)] + [else (symbol->string scope)])) + +;; ---------------------------------------- + +(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 (scope->links-file scope) + (and (path? scope) + (build-path scope "links.rktd"))) + +(define (get-scope-list) + ;; Get a list of scopes suitable for searches with respect to + ;; the current scope + (define current-scope (current-pkg-scope)) + (if (path? current-scope) + (list current-scope) + (member current-scope + (append '(user) + (let ([main (find-pkgs-dir)]) + (for/list ([d (get-pkgs-search-dirs)]) + (if (equal? d main) + 'installation + d))))))) + +(define (pkg-directory pkg-name) + ;; Warning: takes locks individually. + (pkg-directory** pkg-name + (lambda (f) + (with-pkg-lock/read-only + (f))))) + +(define (pkg-directory** pkg-name [call-with-pkg-lock (lambda (f) (f))]) + (for/or ([scope (in-list (get-scope-list))]) + (parameterize ([current-pkg-scope scope]) + (call-with-pkg-lock + (lambda () + (pkg-directory* pkg-name)))))) + +(define (pkg-directory* pkg-name #:db [db #f]) + (define info (package-info pkg-name #f #:db db)) + (and info + (let () + (match-define (pkg-info orig-pkg checksum _) info) + (match orig-pkg + [`(,(or 'link 'static-link) ,orig-pkg-dir) + (path->complete-path orig-pkg-dir (pkg-installed-dir))] + [_ + (build-path (pkg-installed-dir) + (or (cond + [(pkg-info/alt? info) + (pkg-info/alt-dir-name info)] + [(sc-pkg-info/alt? info) + (sc-pkg-info/alt-dir-name info)] + [else #f]) + pkg-name))])))) + +(define (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name) + ;; Picks the right structure subtype + (if single-collect + (if alt-dir-name + (sc-pkg-info/alt orig-pkg checksum auto? single-collect alt-dir-name) + (sc-pkg-info orig-pkg checksum auto? single-collect)) + (if alt-dir-name + (pkg-info/alt orig-pkg checksum auto? alt-dir-name) + (pkg-info orig-pkg checksum auto?)))) + +(define (update-auto this-pkg-info auto?) + (match-define (pkg-info orig-pkg checksum _) this-pkg-info) + (make-pkg-info orig-pkg checksum auto? + (and (sc-pkg-info? this-pkg-info) + (sc-pkg-info-collect this-pkg-info)) + (or (and (sc-pkg-info/alt? this-pkg-info) + (sc-pkg-info/alt-dir-name this-pkg-info)) + (and (pkg-info/alt? this-pkg-info) + (pkg-info/alt-dir-name this-pkg-info))))) + +;; ---------------------------------------- + +(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<=?)) diff --git a/racket/collects/pkg/private/print.rkt b/racket/collects/pkg/private/print.rkt new file mode 100644 index 0000000000..69061c333f --- /dev/null +++ b/racket/collects/pkg/private/print.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require racket/format + "params.rkt") + +;; Output and error helpers + +(provide (all-defined-out)) + +(define-logger pkg) + +(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))) + +(define (printf/flush fmt . args) + ;; For status reporting, flush immediately after printing + (apply printf fmt args) + (flush-output)) + +(define (complain-about-source s reason) + (pkg-error (~a "invalid package source;\n" + " ~a\n" + " given: ~a") + reason + s)) diff --git a/racket/collects/pkg/private/remove.rkt b/racket/collects/pkg/private/remove.rkt new file mode 100644 index 0000000000..b6df2c973f --- /dev/null +++ b/racket/collects/pkg/private/remove.rkt @@ -0,0 +1,152 @@ +#lang racket/base +(require racket/match + setup/link + racket/file + racket/set + racket/list + racket/format + "../path.rkt" + "pkg-db.rkt" + "collects.rkt" + "params.rkt" + "print.rkt" + "get-info.rkt") + +(provide remove-package + pkg-remove) + +(define (demote-packages quiet? pkg-names) + (define db (read-pkg-db)) + (for ([pkg-name (in-list pkg-names)]) + (define pi (package-info pkg-name #:db db)) + (unless (pkg-info-auto? pi) + (unless quiet? + (printf/flush "Demoting ~a to auto-installed\n" pkg-name)) + (update-pkg-db! pkg-name (update-auto pi #t))))) + +(define ((remove-package quiet?) pkg-name) + (unless quiet? + (printf/flush "Removing ~a\n" pkg-name)) + (define db (read-pkg-db)) + (define pi (package-info pkg-name #:db db)) + (match-define (pkg-info orig-pkg checksum _) pi) + (define pkg-dir (pkg-directory* pkg-name #:db db)) + (remove-from-pkg-db! pkg-name) + (define scope (current-pkg-scope)) + (define user? (not (or (eq? scope 'installation) + (path? scope)))) + (match orig-pkg + [`(,(or 'link 'static-link) ,_) + (links pkg-dir + #:remove? #t + #:user? user? + #:file (scope->links-file scope) + #:root? (not (sc-pkg-info? pi)))] + [_ + (links pkg-dir + #:remove? #t + #:user? user? + #:file (scope->links-file scope) + #:root? (not (sc-pkg-info? pi))) + (delete-directory/files pkg-dir)])) + + + +(define (pkg-remove given-pkgs + #:demote? [demote? #f] + #:force? [force? #f] + #:auto? [auto? #f] + #:quiet? [quiet? #f] + #:from-command-line? [from-command-line? #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 in-pkgs (remove-duplicates given-pkgs)) + (define remove-pkgs + (if auto? + ;; compute fixpoint: + (let ([init-drop (set-union + (list->set + (filter + (λ (p) (pkg-info-auto? (hash-ref db p))) + all-pkgs)) + (list->set in-pkgs))]) + (let loop ([drop init-drop] + [keep (set-subtract + (list->set all-pkgs) + init-drop)]) + (define deps + (list->set + (append-map (package-dependencies metadata-ns db #t) + (set->list keep)))) + (define still-drop (set-subtract drop deps)) + (define delta (set-subtract drop still-drop)) + (if (set-empty? delta) + (set->list drop) + (loop still-drop + (set-union keep delta))))) + ;; just given pkgs: + (if demote? + null + in-pkgs))) + (define setup-collects + (get-setup-collects remove-pkgs + db + metadata-ns)) + (unless (or force? demote?) + ;; Check dependencies on `in-pkgs' (not `pkgs', which has already + ;; been filtered to remove package with dependencies if `auto?' is + ;; true). + (define pkgs-set (list->set in-pkgs)) + (define remaining-pkg-db-set + (set-subtract all-pkgs-set + (if auto? + (list->set remove-pkgs) + pkgs-set))) + (define deps-to-be-removed + (set-intersect + pkgs-set + (list->set + (append-map (package-dependencies metadata-ns db #t) + (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 db #t) dp))) + (set->list + remaining-pkg-db-set))) + (~a p " (required by: " ds ")")) + (set->list deps-to-be-removed)))))) + + (when demote? + ;; Demote any package that is not going to be removed: + (demote-packages + quiet? + (set->list (set-subtract (list->set in-pkgs) + (list->set remove-pkgs))))) + + (for-each (remove-package quiet?) + remove-pkgs) + + (cond + [(or (null? remove-pkgs) demote?) + ;; Did nothing, so no setup: + 'skip] + [else + ;; 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))])) + diff --git a/racket/collects/pkg/private/show.rkt b/racket/collects/pkg/private/show.rkt new file mode 100644 index 0000000000..d516dd2e77 --- /dev/null +++ b/racket/collects/pkg/private/show.rkt @@ -0,0 +1,69 @@ +#lang racket/base +(require racket/list + racket/match + racket/format + racket/function + "../path.rkt" + "pkg-db.rkt") + +(provide pkg-show) + +(define (pkg-show indent + #:directory? [dir? #f] + #:auto? [show-auto? #f]) + (let () + (define db (read-pkg-db)) + (define pkgs (sort (hash-keys db) string-ci<=?)) + (if (null? pkgs) + (printf " [none]\n") + (begin + (table-display + (list* + (append + (list (format "~aPackage~a" + indent + (if show-auto? "[*=auto]" "")) + "Checksum" + "Source") + (if dir? + (list "Directory") + empty)) + (for/list ([pkg (in-list pkgs)] + #:when (or show-auto? + (not (pkg-info-auto? (hash-ref db pkg))))) + (match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg)) + (append + (list (format "~a~a~a" + indent + pkg + (if auto? "*" "")) + (format "~a" checksum) + (format "~a" orig-pkg)) + (if dir? + (list (~a (pkg-directory* pkg #:db db))) + empty))))) + (unless show-auto? + (define n (for/sum ([pkg (in-list pkgs)] + #:when (pkg-info-auto? (hash-ref db pkg))) + 1)) + (unless (zero? n) + (printf "~a[~a auto-installed package~a not shown]\n" + indent + n + (if (= n 1) "" "s")))))))) + +(define (table-display l) + (define how-many-cols (length (first l))) + (define max-widths + (for/list ([col (in-range how-many-cols)]) + (apply max (map (compose string-length (curryr list-ref col)) l)))) + (for ([row (in-list l)]) + (for ([col (in-list row)] + [i (in-naturals 1)] + [width (in-list max-widths)]) + (printf "~a~a" + col + (if (= i how-many-cols) + "" + (make-string (+ (- width (string-length col)) 4) #\space)))) + (printf "\n"))) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt new file mode 100644 index 0000000000..ccc9d07f5f --- /dev/null +++ b/racket/collects/pkg/private/stage.rkt @@ -0,0 +1,598 @@ +#lang racket/base +(require racket/format + racket/match + racket/list + racket/path + racket/file + racket/port + racket/string + setup/unpack + setup/dirs + net/url + file/untgz + file/unzip + openssl/sha1 + json + "../name.rkt" + "../strip.rkt" + "catalog.rkt" + "download.rkt" + "print.rkt" + "path.rkt" + "dirs.rkt" + "desc.rkt" + "params.rkt" + "get-info.rkt" + "mod-paths.rkt" + "addl-installs.rkt") + +(provide (struct-out install-info) + remote-package-checksum + stage-package/info + pkg-stage) + +(struct install-info (name orig-pkg directory clean? checksum module-paths additional-installs)) + +(define (remote-package-checksum pkg download-printf pkg-name) + (match pkg + [`(catalog ,pkg-name) + (hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)] + [`(url ,pkg-url-str) + (package-url->checksum pkg-url-str + #:download-printf download-printf + #:pkg-name pkg-name)])) + +;; 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] + #:cached-url [cached-url #f] + #:use-cache? use-cache? + check-sums? + download-printf + metadata-ns + #:strip [strip-mode #f] + #:force-strip? [force-strip? #f] + #:in-place? [in-place? #f] + #:in-place-clean? [in-place-clean? #f] + #:link-dirs? [link-dirs? #f]) + (define-values (inferred-pkg-name type) + (if (path? pkg) + (package-source->name+type (path->string pkg) + (or given-type + (if (directory-exists? pkg) + (if link-dirs? + 'link + 'dir) + 'file)) + #:must-infer-name? (not given-pkg-name) + #:complain complain-about-source) + (package-source->name+type pkg given-type + #:link-dirs? link-dirs? + #:must-infer-name? (not given-pkg-name) + #:complain complain-about-source))) + (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"^git(?:hub)?://" pkg))) + ;; Add "git://github.com/" + (stage-package/info (string-append "git://github.com/" pkg) type + pkg-name + #:given-checksum given-checksum + #:use-cache? use-cache? + check-sums? download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip?)] + [(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 found-checksum + ;; If a checksum is given, use that. In the case of a non-github + ;; source, we could try to get the checksum from the source, and + ;; then check whether it matches the expected one, but we choose + ;; to avoid an extra trip to the server. + (or given-checksum + (remote-package-checksum orig-pkg download-printf pkg-name))) + (when check-sums? + (check-checksum given-checksum found-checksum "unexpected" pkg #f)) + (define checksum (or found-checksum given-checksum)) + (define downloaded-info + (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)) + (when (equal? checksum "") + (pkg-error + (~a "cannot use empty checksum for GitHub package source\n" + " source: ~a") + pkg)) + (match-define (list* user repo branch path) + (split-github-url 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)) + + (dynamic-wind + void + (λ () + (download-file! new-url tmp.tgz checksum + #:use-cache? use-cache? + #:download-printf download-printf) + (define staged? #f) + (dynamic-wind + void + (λ () + (untar tmp.tgz tmp-dir #:strip-components 1) + + (unless (null? path) + (unless (directory-exists? (apply build-path tmp-dir path)) + (pkg-error + (~a "specified directory is not in GitHub respository archive\n" + " path: ~a" + (apply build-path path)))) + (lift-directory-content tmp-dir path)) + + (begin0 + (stage-package/info tmp-dir + 'dir + pkg-name + #:given-checksum checksum + #:cached-url new-url + #:use-cache? use-cache? + check-sums? + download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip? + #:in-place? #t + #:in-place-clean? #t) + (set! staged? #t))) + (λ () + (when (and use-cache? (not staged?)) + (clean-cache new-url checksum)) + (unless staged? + (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 "Cloning 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) + #f + #:use-cache? use-cache?))))] + [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 checksum + #:use-cache? use-cache? + #:download-printf download-printf)))])) + (define staged? #f) + (dynamic-wind + void + (λ () + (download-package!) + (log-pkg-debug "\tDownloading done, installing ~a as ~a" + package-path pkg-name) + (begin0 + (stage-package/info package-path + download-type + pkg-name + #:given-checksum checksum + #:cached-url pkg-url + #:use-cache? use-cache? + check-sums? + download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip?) + (set! staged? #t))) + (λ () + (when (or (file-exists? package-path) + (directory-exists? package-path)) + (when (and use-cache? (not staged?)) + (clean-cache pkg-url checksum)) + (delete-directory/files package-path))))])) + (define info (update-install-info-orig-pkg downloaded-info + 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 check-sums? + (check-checksum checksum (install-info-checksum info) + "mismatched" + pkg + (and use-cache? cached-url))) + (update-install-info-checksum + info + checksum)] + [(eq? type 'file) + (define pkg-path (if (path? pkg) + pkg + (package-source->path pkg type))) + (unless (file-exists? pkg-path) + (pkg-error "no such file\n path: ~a" pkg-path)) + (define checksum-pth (format "~a.CHECKSUM" pkg-path)) + (define expected-checksum + (and (file-exists? checksum-pth) + check-sums? + (file->string checksum-pth))) + (check-checksum given-checksum expected-checksum "unexpected" pkg-path #f) + (define actual-checksum + (with-input-from-file pkg-path + (λ () + (sha1 (current-input-port))))) + (check-checksum expected-checksum actual-checksum "mismatched" pkg-path + (and use-cache? cached-url)) + (define checksum + actual-checksum) + (define pkg-format (filename-extension pkg-path)) + (define pkg-dir + (make-temporary-file (string-append "~a-" pkg-name) + 'directory)) + (define staged? #f) + (dynamic-wind + void + (λ () + (make-directory* pkg-dir) + + (match pkg-format + [#"tgz" + (untar pkg-path pkg-dir) + (remove-extra-directory-layer pkg-dir)] + [#"tar" + (untar pkg-path pkg-dir) + (remove-extra-directory-layer pkg-dir)] + [#"gz" ; assuming .tar.gz + (untar pkg-path pkg-dir) + (remove-extra-directory-layer pkg-dir)] + [#"zip" + (unzip pkg-path (make-filesystem-entry-reader #:dest pkg-dir) + #:preserve-timestamps? #t + #:utc-timestamps? #t) + (remove-extra-directory-layer pkg-dir)] + [#"plt" + (make-directory* pkg-dir) + (unpack pkg-path pkg-dir + (lambda (x) (log-pkg-debug "~a" x)) + (lambda () pkg-dir) + #f + (lambda (auto-dir main-dir file) pkg-dir)) + (define info-path (build-path pkg-dir "info.rkt")) + (unless (file-exists? info-path) + ;; Add in "info.rkt" file to make it multi-collection, + ;; since a ".plt" archive is never single-collection. This + ;; is needed for supporting old ".plt" archives as packages. + (call-with-output-file info-path + (lambda (o) + (fprintf o "#lang setup/infotab\n") + (write '(define collection 'multi) o) + (newline o))))] + [x + (pkg-error "invalid package format\n given: ~a" x)]) + + (begin0 + (update-install-info-checksum + (update-install-info-orig-pkg + (stage-package/info pkg-dir + 'dir + pkg-name + #:given-checksum checksum + #:cached-url cached-url + #:use-cache? use-cache? + check-sums? + download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip? + #:in-place? (not strip-mode) + #:in-place-clean? #t) + `(file ,(simple-form-path* pkg-path))) + checksum) + (unless strip-mode + (set! staged? #t)))) + (λ () + (unless staged? + (delete-directory/files pkg-dir))))] + [(or (eq? type 'dir) + (eq? type 'link) + (eq? type 'static-link)) + (define pkg-path (if (path? pkg) + pkg + (package-source->path pkg type))) + (unless (directory-exists? pkg-path) + (pkg-error "no such directory\n path: ~a" pkg-path)) + (let ([pkg-path (directory-path-no-slash pkg-path)]) + (cond + [(or (eq? type 'link) + (eq? type 'static-link)) + (install-info pkg-name + `(,type ,(path->string + (find-relative-path (pkg-installed-dir) + (simple-form-path pkg-path) + #:more-than-root? #t))) + pkg-path + #f + given-checksum ; if a checksum is provided, just use it + (directory->module-paths pkg pkg-name metadata-ns) + (directory->additional-installs pkg pkg-name metadata-ns))] + [else + (define pkg-dir + (if in-place? + (if strip-mode + (pkg-error "cannot strip directory in place") + pkg-path) + (let ([pkg-dir (make-temporary-file "pkg~a" 'directory)]) + (delete-directory pkg-dir) + (if strip-mode + (begin + (unless force-strip? + (check-strip-compatible strip-mode pkg-name pkg pkg-error)) + (make-directory* pkg-dir) + (generate-stripped-directory strip-mode pkg pkg-dir)) + (begin + (make-parent-directory* pkg-dir) + (copy-directory/files pkg-path pkg-dir #:keep-modify-seconds? #t))) + pkg-dir))) + (when (or (not in-place?) + in-place-clean?) + (drop-redundant-files pkg-dir)) + (install-info pkg-name + `(dir ,(simple-form-path* pkg-path)) + pkg-dir + (or (not in-place?) in-place-clean?) + given-checksum ; if a checksum is provided, just use it + (directory->module-paths pkg-dir pkg-name metadata-ns) + (directory->additional-installs pkg-dir pkg-name metadata-ns))]))] + [(eq? type 'name) + (define catalog-info (package-catalog-lookup pkg #f download-printf)) + (log-pkg-debug "catalog response: ~s" catalog-info) + (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 + #:use-cache? use-cache? + check-sums? + download-printf + metadata-ns + #:strip strip-mode + #:force-strip? force-strip?)) + (when check-sums? + (check-checksum given-checksum checksum "unexpected" pkg #f) + (check-checksum checksum (install-info-checksum info) "incorrect" pkg #f)) + (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 + #:namespace [metadata-ns (make-metadata-namespace)] + #:in-place? [in-place? #f] + #:strip [strip-mode #f] + #:force-strip? [force-strip? #f] + #:use-cache? [use-cache? #f] + #:quiet? [quiet? #t]) + (define i (stage-package/info (pkg-desc-source desc) + (pkg-desc-type desc) + (pkg-desc-name desc) + #:given-checksum (pkg-desc-checksum desc) + #:use-cache? use-cache? + #t + (if quiet? void printf) + metadata-ns + #:in-place? in-place? + #:strip strip-mode + #:force-strip? force-strip?)) + (values (install-info-name i) + (install-info-directory i) + (install-info-checksum i) + (install-info-clean? i) + (install-info-module-paths i))) + +;; ---------------------------------------- + +(define (package-url->checksum pkg-url-str [query empty] + #:download-printf [download-printf void] + #:pkg-name [pkg-name "package"]) + (define pkg-url + (string->url pkg-url-str)) + (match (url-scheme pkg-url) + [(or "github" "git") + (match-define (list* user repo branch path) + (split-github-url pkg-url)) + (or + (for/or ([kind '("branches" "tags")]) + (define api-u + (url "https" #f "api.github.com" #f #t + (map (λ (x) (path/param x empty)) + (list "repos" user repo kind)) + (append query + (if (and (github-client_id) + (github-client_secret)) + (list (cons 'client_id (github-client_id)) + (cons 'client_secret (github-client_secret))) + empty)) + #f)) + (download-printf "Querying GitHub ~a\n" kind) + (log-pkg-debug "Querying GitHub at ~a" (url->string api-u)) + (define api-bs + (call/input-url+200 + api-u port->bytes + #:headers (list (format "User-Agent: raco-pkg/~a" (version))))) + (unless api-bs + (error 'package-url->checksum + "could not connect to GitHub\n URL: ~a" + (url->string + (struct-copy url api-u + [query query])))) + (define branches + (read-json (open-input-bytes api-bs))) + (unless (and (list? branches) + (andmap hash? branches) + (andmap (λ (b) (hash-has-key? b 'name)) branches) + (andmap (λ (b) (hash-has-key? b 'commit)) branches)) + (error 'package-url->checksum + "Invalid response from Github: ~e" + api-bs)) + (for/or ([b (in-list branches)]) + (and (equal? (hash-ref b 'name) branch) + (hash-ref (hash-ref b 'commit) 'sha)))) + ;; no matching branch/tag found, so if `branch' matches the + ;; syntax of a commit id, then assume that it refers to a commit + (and (regexp-match? #rx"[a-f0-9]+" branch) + branch))] + [_ + (define u (string-append pkg-url-str ".CHECKSUM")) + (download-printf "Downloading checksum for ~a\n" pkg-name) + (log-pkg-debug "Downloading checksum as ~a" u) + (call/input-url+200 (string->url u) + port->string)])) + +(define (check-checksum given-checksum checksum what pkg-src cached-url) + (when (and given-checksum + checksum + (not (equal? given-checksum checksum))) + (clean-cache cached-url checksum) + (pkg-error (~a "~a checksum on package\n" + " package source: ~a\n" + " expected: ~e\n" + " got: ~e") + what + pkg-src + given-checksum + 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 github-client_id (make-parameter #f)) +(define github-client_secret (make-parameter #f)) + +(define (split-github-url pkg-url) + (if (equal? (url-scheme pkg-url) "github") + ;; github:// + (map path/param-path (url-path/no-slash pkg-url)) + ;; git:// + (let* ([paths (map path/param-path (url-path/no-slash pkg-url))]) + (list* (car paths) + (regexp-replace* #rx"[.]git$" (cadr paths) "") + (or (url-fragment pkg-url) "master") + (let ([a (assoc 'path (url-query pkg-url))]) + (or (and a (cdr a) (string-split (cdr a) "/")) + null)))))) + +;; ---------------------------------------- + +(define (untar pkg pkg-dir #:strip-components [strip-components 0]) + (make-directory* pkg-dir) + (untgz pkg #:dest pkg-dir #:strip-count strip-components)) + +;; ---------------------------------------- + +(define (drop-redundant-files pkg-dir) + ;; Ad hoc space-saving rule: for an installation-wide package, remove + ;; any redundant "COPYING.txt" or "COPYING_LESSER.txt" files. + (when (and (eq? 'installation (current-pkg-scope)) + (find-share-dir)) + (for ([i (in-list '("COPYING.txt" "COPYING_LESSER.txt"))]) + (define pkg-file (build-path pkg-dir i)) + (define share-file (build-path (find-share-dir) i)) + (when (and (file-exists? pkg-file) + (file-exists? share-file) + (equal? (file->bytes pkg-file) + (file->bytes share-file))) + ;; This file would be redundant, so drop it + (delete-file pkg-file))))) diff --git a/racket/collects/pkg/private/suggestions.rkt b/racket/collects/pkg/private/suggestions.rkt new file mode 100644 index 0000000000..ef98c28eb2 --- /dev/null +++ b/racket/collects/pkg/private/suggestions.rkt @@ -0,0 +1,39 @@ +#lang racket/base +(require racket/set + racket/path + setup/dirs + syntax/modcollapse + (prefix-in db: "../db.rkt")) + +(provide pkg-catalog-suggestions-for-module) + +(define (choose-catalog-file) + (define default (db:current-pkg-catalog-file)) + (if (file-exists? default) + default + (let ([installation (build-path (find-share-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)))) + stringstring u)) - (define-values (ip hs) (get-pure-port/headers u headers - #:redirections 25 - #:status? #t)) - (if (string=? "200" (substring hs 9 12)) - (begin0 - (fun ip) - (close-input-port ip)) - (fail-k hs))) - -(define (url-path/no-slash url) - (define p (url-path url)) - (define rp (reverse p)) - (reverse - (match rp - [(list* (path/param "" _) rest) - rest] - [_ rp]))) - -(define github-client_id (make-parameter #f)) -(define github-client_secret (make-parameter #f)) - -(define (split-github-url pkg-url) - (if (equal? (url-scheme pkg-url) "github") - ;; github:// - (map path/param-path (url-path/no-slash pkg-url)) - ;; git:// - (let* ([paths (map path/param-path (url-path/no-slash pkg-url))]) - (list* (car paths) - (regexp-replace* #rx"[.]git$" (cadr paths) "") - (or (url-fragment pkg-url) "master") - (let ([a (assoc 'path (url-query pkg-url))]) - (or (and a (cdr a) (string-split (cdr a) "/")) - null)))))) - -(define (package-url->checksum pkg-url-str [query empty] - #:download-printf [download-printf void] - #:pkg-name [pkg-name "package"]) - (define pkg-url - (string->url pkg-url-str)) - (match (url-scheme pkg-url) - [(or "github" "git") - (match-define (list* user repo branch path) - (split-github-url pkg-url)) - (or - (for/or ([kind '("branches" "tags")]) - (define api-u - (url "https" #f "api.github.com" #f #t - (map (λ (x) (path/param x empty)) - (list "repos" user repo kind)) - (append query - (if (and (github-client_id) - (github-client_secret)) - (list (cons 'client_id (github-client_id)) - (cons 'client_secret (github-client_secret))) - empty)) - #f)) - (download-printf "Querying GitHub ~a\n" kind) - (log-pkg-debug "Querying GitHub at ~a" (url->string api-u)) - (define api-bs - (call/input-url+200 - api-u port->bytes - #:headers (list (format "User-Agent: raco-pkg/~a" (version))))) - (unless api-bs - (error 'package-url->checksum - "could not connect to GitHub\n URL: ~a" - (url->string - (struct-copy url api-u - [query query])))) - (define branches - (read-json (open-input-bytes api-bs))) - (unless (and (list? branches) - (andmap hash? branches) - (andmap (λ (b) (hash-has-key? b 'name)) branches) - (andmap (λ (b) (hash-has-key? b 'commit)) branches)) - (error 'package-url->checksum - "Invalid response from Github: ~e" - api-bs)) - (for/or ([b (in-list branches)]) - (and (equal? (hash-ref b 'name) branch) - (hash-ref (hash-ref b 'commit) 'sha)))) - ;; no matching branch/tag found, so if `branch' matches the - ;; syntax of a commit id, then assume that it refers to a commit - (and (regexp-match? #rx"[a-f0-9]+" branch) - branch))] - [_ - (define u (string-append pkg-url-str ".CHECKSUM")) - (download-printf "Downloading checksum for ~a\n" pkg-name) - (log-pkg-debug "Downloading checksum as ~a" u) - (call/input-url+200 (string->url u) - port->string)])) - -;; uses a custodian to avoid leaks: -(define (call-with-url url handler) - (define c (make-custodian)) - (dynamic-wind - void - (lambda () - (define-values (p hs) - (parameterize ([current-custodian c]) - (get-pure-port/headers url #:redirections 25 #:status? #t))) - (begin0 - (and (string=? "200" (substring hs 9 12)) - (handler p)) - (close-input-port p))) - (lambda () - (custodian-shutdown-all c)))) - -(define (read-from-server who url pred - [failure - (lambda (s) - (error who - (~a "bad response from server\n" - " url: ~a\n" - " response: ~v") - (url->string url) - s))]) - (define bytes (call-with-url url port->bytes)) - ((if bytes - (with-handlers ([exn:fail:read? (lambda (exn) - (lambda () (failure bytes)))]) - (define v (read (open-input-bytes bytes))) - (lambda () - (if (pred v) - v - (failure bytes)))) - (lambda () (failure #f))))) - -(define (lift-directory-content pkg-dir path) - (define orig-sub (let ([s (car path)]) - (if (string? s) - (string->path s) - s))) - ;; Delete everything except `orig-sub`: - (for ([f (in-list (directory-list pkg-dir))]) - (unless (equal? f orig-sub) - (delete-directory/files (build-path pkg-dir f)))) - ;; Get list of files and directories to move: - (define sub-l (directory-list (apply build-path pkg-dir path))) - ;; Make sure `sub` doesn't match a name we want to move here: - (define sub - (let loop ([sub orig-sub] [i 0]) - (cond - [(member sub sub-l) - ;; pick a new name: - (loop (string->path (format "sub~a" i)) (add1 i))] - [(not (equal? sub orig-sub)) - (rename-file-or-directory (build-path pkg-dir orig-sub) - (build-path pkg-dir sub)) - sub] - [else sub]))) - ;; Move content of `sub` out: - (define sub-path (apply build-path (cons sub (cdr path)))) - (for ([f (in-list sub-l)]) - (rename-file-or-directory (build-path pkg-dir sub-path f) - (build-path pkg-dir f))) - ;; Remove directory that we moved files out of: - (delete-directory/files (build-path pkg-dir sub))) - -(define (remove-extra-directory-layer pkg-dir) - ;; Treat a single directory produced in `pkg-dir` - ;; as having the content of the package, instead of - ;; being included itself in the package content. - (define l (directory-list pkg-dir)) - (when (= 1 (length l)) - (define orig-sub (car l)) - (when (directory-exists? (build-path pkg-dir orig-sub)) - (lift-directory-content pkg-dir (list orig-sub))))) - -(provide (all-defined-out))