reorganize pkg/lib implementation
Split the module into several (smaller) modules.
This commit is contained in:
Matthew Flatt
parent
1cc86d3cea
commit
5650e8fc03
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@
|
|||
file/zip
|
||||
file/unzip
|
||||
net/url
|
||||
pkg/util
|
||||
setup/dirs
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
(require rackunit
|
||||
racket/file
|
||||
racket/format
|
||||
pkg/util
|
||||
(prefix-in db: pkg/db)
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@
|
|||
racket/path
|
||||
racket/list
|
||||
racket/format
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@
|
|||
racket/list
|
||||
racket/format
|
||||
setup/dirs
|
||||
pkg/util
|
||||
"shelly.rkt")
|
||||
|
||||
(define-runtime-path test-directory ".")
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
154
racket/collects/pkg/private/addl-installs.rkt
Normal file
154
racket/collects/pkg/private/addl-installs.rkt
Normal file
|
|
@ -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)))
|
||||
|
||||
175
racket/collects/pkg/private/archive.rkt
Normal file
175
racket/collects/pkg/private/archive.rkt
Normal file
|
|
@ -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))
|
||||
125
racket/collects/pkg/private/catalog-archive.rkt
Normal file
125
racket/collects/pkg/private/catalog-archive.rkt
Normal file
|
|
@ -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 string<? #:key db:pkg-name))])
|
||||
(define name (db:pkg-name pkg))
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(package-exn-handler name exn))])
|
||||
(define current-checksum (and state-catalog
|
||||
(parameterize ([db:current-pkg-catalog-file state-catalog])
|
||||
(define l (db:get-pkgs #:name (db:pkg-name pkg)))
|
||||
(and (= 1 (length l))
|
||||
(db:pkg-checksum (car l))))))
|
||||
(define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name)))
|
||||
(define pkg-checksum-file (path-replace-suffix pkg-file #".zip.CHECKSUM"))
|
||||
(unless (and current-checksum
|
||||
(equal? current-checksum (db:pkg-checksum pkg))
|
||||
(file-exists? pkg-file)
|
||||
(file-exists? pkg-checksum-file)
|
||||
(equal? (file->string 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))
|
||||
162
racket/collects/pkg/private/catalog-copy.rkt
Normal file
162
racket/collects/pkg/private/catalog-copy.rkt
Normal file
|
|
@ -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)))]))
|
||||
|
||||
82
racket/collects/pkg/private/catalog-show.rkt
Normal file
82
racket/collects/pkg/private/catalog-show.rkt
Normal file
|
|
@ -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) string<?)
|
||||
names))]
|
||||
[position (in-naturals)])
|
||||
(define details (select-info-version
|
||||
(if all?
|
||||
(hash-ref all-details name)
|
||||
(get-pkg-details-from-catalogs name))))
|
||||
(unless (zero? position) (newline))
|
||||
(printf "Package name: ~a\n" name)
|
||||
(for ([key '(author source checksum tags description)])
|
||||
(define v (hash-ref details key #f))
|
||||
(when v
|
||||
(printf " ~a: ~a\n"
|
||||
(string-titlecase (symbol->string key))
|
||||
(if (list? v)
|
||||
(apply ~a #:separator ", " v)
|
||||
v))))
|
||||
(for ([key '(dependencies)])
|
||||
(define v (hash-ref details key null))
|
||||
(unless (null? v)
|
||||
(printf " Dependencies:\n")
|
||||
(for ([dep (in-list v)])
|
||||
(define vers (dependency->version dep))
|
||||
(define plat (dependency-lookup '#:platform dep))
|
||||
(printf " ~a~a~a\n"
|
||||
(dependency->name dep)
|
||||
(if vers
|
||||
(format " version ~a" vers)
|
||||
"")
|
||||
(if plat
|
||||
(format " on platform ~v" plat)
|
||||
"")))))
|
||||
(when modules?
|
||||
(printf " Modules:")
|
||||
(for/fold ([col 72]) ([mod (in-list (hash-ref details 'modules null))])
|
||||
(define pretty-mod (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)))]))
|
||||
|
||||
81
racket/collects/pkg/private/catalog-update.rkt
Normal file
81
racket/collects/pkg/private/catalog-update.rkt
Normal file
|
|
@ -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)))))))
|
||||
|
||||
306
racket/collects/pkg/private/catalog.rkt
Normal file
306
racket/collects/pkg/private/catalog.rkt
Normal file
|
|
@ -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) string<?))
|
||||
|
||||
(define (get-pkg-details-from-catalogs name)
|
||||
(for/or ([i (in-list (pkg-catalogs))])
|
||||
(package-catalog-lookup name #t #f)))
|
||||
|
||||
(define (get-all-pkg-details-from-catalogs)
|
||||
(for/fold ([ht (hash)]) ([i (in-list (pkg-catalogs))])
|
||||
(define one-ht
|
||||
(catalog-dispatch
|
||||
i
|
||||
;; Server:
|
||||
(lambda (i)
|
||||
(read-from-server
|
||||
'get-all-pkg-details-from-catalogs
|
||||
(add-version-query
|
||||
(combine-url/relative i "pkgs-all"))
|
||||
(lambda (v)
|
||||
(and (hash? v)
|
||||
(for/and ([(k v) (in-hash v)])
|
||||
(and (string? k)
|
||||
(hash? v)
|
||||
(for/and ([k (in-hash-keys v)])
|
||||
(symbol? k))))))))
|
||||
;; Local database:
|
||||
(lambda ()
|
||||
(define pkgs (db:get-pkgs))
|
||||
(for/fold ([ht (hash)]) ([p (in-list pkgs)])
|
||||
(if (hash-ref ht (db:pkg-name p) #f)
|
||||
ht
|
||||
(hash-set ht
|
||||
(db:pkg-name p)
|
||||
(db-pkg-info p #t)))))
|
||||
;; Local directory:
|
||||
(lambda (path)
|
||||
(define pkgs-all-path (build-path path "pkgs-all"))
|
||||
(cond
|
||||
[(file-exists? pkgs-all-path)
|
||||
(call-with-input-file* pkgs-all-path read)]
|
||||
[else
|
||||
(define pkg-path (build-path path "pkg"))
|
||||
(for/hash ([i (directory-list pkg-path)]
|
||||
#:when (file-exists? (build-path pkg-path i)))
|
||||
(values (path-element->string i)
|
||||
(call-with-input-file* (build-path pkg-path i)
|
||||
read)))]))))
|
||||
(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))))))
|
||||
71
racket/collects/pkg/private/collects.rkt
Normal file
71
racket/collects/pkg/private/collects.rkt
Normal file
|
|
@ -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))))))))
|
||||
202
racket/collects/pkg/private/config.rkt
Normal file
202
racket/collects/pkg/private/config.rkt
Normal file
|
|
@ -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 "")])]))
|
||||
50
racket/collects/pkg/private/content.rkt
Normal file
50
racket/collects/pkg/private/content.rkt
Normal file
|
|
@ -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))))
|
||||
196
racket/collects/pkg/private/create.rkt
Normal file
196
racket/collects/pkg/private/create.rkt
Normal file
|
|
@ -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?)]))
|
||||
36
racket/collects/pkg/private/dep.rkt
Normal file
36
racket/collects/pkg/private/dep.rkt
Normal file
|
|
@ -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)))
|
||||
|
||||
15
racket/collects/pkg/private/desc.rkt
Normal file
15
racket/collects/pkg/private/desc.rkt
Normal file
|
|
@ -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)))
|
||||
38
racket/collects/pkg/private/dirs.rkt
Normal file
38
racket/collects/pkg/private/dirs.rkt
Normal file
|
|
@ -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)))
|
||||
87
racket/collects/pkg/private/download.rkt
Normal file
87
racket/collects/pkg/private/download.rkt
Normal file
|
|
@ -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))))))
|
||||
32
racket/collects/pkg/private/get-info.rkt
Normal file
32
racket/collects/pkg/private/get-info.rkt
Normal file
|
|
@ -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)
|
||||
|
||||
1024
racket/collects/pkg/private/install.rkt
Normal file
1024
racket/collects/pkg/private/install.rkt
Normal file
File diff suppressed because it is too large
Load Diff
71
racket/collects/pkg/private/lock.rkt
Normal file
71
racket/collects/pkg/private/lock.rkt
Normal file
|
|
@ -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))))
|
||||
120
racket/collects/pkg/private/metadata.rkt
Normal file
120
racket/collects/pkg/private/metadata.rkt
Normal file
|
|
@ -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)))))
|
||||
71
racket/collects/pkg/private/migrate.rkt
Normal file
71
racket/collects/pkg/private/migrate.rkt
Normal file
|
|
@ -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))
|
||||
string<?
|
||||
#:key pkg-desc-name))
|
||||
(unless quiet?
|
||||
(cond
|
||||
[(null? to-install)
|
||||
(printf "No packages from ~s to install\n" from-version)]
|
||||
[else
|
||||
(printf "Packages to install:\n")
|
||||
(for ([d (in-list to-install)])
|
||||
(define t (pkg-desc-type d))
|
||||
(define n (pkg-desc-name d))
|
||||
(case t
|
||||
[(name) (printf " ~a\n" n)]
|
||||
[(link static-link)
|
||||
(printf " ~a ~aed from ~a\n" n t (pkg-desc-source d))]
|
||||
[else
|
||||
(printf " ~a from ~a\n" n (pkg-desc-source d))]))]))
|
||||
(if (null? to-install)
|
||||
'skip
|
||||
(begin0
|
||||
(pkg-install to-install
|
||||
#:all-platforms? all-platforms?
|
||||
#:force? force?
|
||||
#:ignore-checksums? ignore-checksums?
|
||||
#:strict-doc-conflicts? strict-doc-conflicts?
|
||||
#:use-cache? use-cache?
|
||||
#:skip-installed? #t
|
||||
#:dep-behavior (or dep-behavior 'search-auto)
|
||||
#:quiet? quiet?
|
||||
#:from-command-line? from-command-line?
|
||||
#:strip strip-mode
|
||||
#:force-strip? force-strip?)
|
||||
(unless quiet?
|
||||
(printf "Packages migrated\n")))))
|
||||
84
racket/collects/pkg/private/mod-paths.rkt
Normal file
84
racket/collects/pkg/private/mod-paths.rkt
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
#lang racket/base
|
||||
(require racket/set
|
||||
racket/format
|
||||
syntax/modcollapse
|
||||
"metadata.rkt"
|
||||
"get-info.rkt")
|
||||
|
||||
(provide pkg-directory->module-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])])]))))
|
||||
|
||||
29
racket/collects/pkg/private/params.rkt
Normal file
29
racket/collects/pkg/private/params.rkt
Normal file
|
|
@ -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))
|
||||
|
||||
85
racket/collects/pkg/private/path.rkt
Normal file
85
racket/collects/pkg/private/path.rkt
Normal file
|
|
@ -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)))))
|
||||
220
racket/collects/pkg/private/pkg-db.rkt
Normal file
220
racket/collects/pkg/private/pkg-db.rkt
Normal file
|
|
@ -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<=?))
|
||||
37
racket/collects/pkg/private/print.rkt
Normal file
37
racket/collects/pkg/private/print.rkt
Normal file
|
|
@ -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))
|
||||
152
racket/collects/pkg/private/remove.rkt
Normal file
152
racket/collects/pkg/private/remove.rkt
Normal file
|
|
@ -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))]))
|
||||
|
||||
69
racket/collects/pkg/private/show.rkt
Normal file
69
racket/collects/pkg/private/show.rkt
Normal file
|
|
@ -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")))
|
||||
598
racket/collects/pkg/private/stage.rkt
Normal file
598
racket/collects/pkg/private/stage.rkt
Normal file
|
|
@ -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)))))
|
||||
39
racket/collects/pkg/private/suggestions.rkt
Normal file
39
racket/collects/pkg/private/suggestions.rkt
Normal file
|
|
@ -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))))
|
||||
string<?)))
|
||||
null))
|
||||
|
||||
|
||||
|
|
@ -1,208 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/path
|
||||
racket/list
|
||||
racket/function
|
||||
racket/file
|
||||
racket/port
|
||||
racket/match
|
||||
racket/format
|
||||
racket/string
|
||||
racket/set
|
||||
net/url
|
||||
json)
|
||||
|
||||
(define-logger pkg)
|
||||
|
||||
(define (make-parent-directory* p)
|
||||
(define parent (path-only p))
|
||||
(make-directory* parent))
|
||||
|
||||
(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")))
|
||||
|
||||
(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 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))
|
||||
Loading…
Reference in New Issue
Block a user