suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco pkg archive-catalog: add --include and --exclude

Browse Source 
Also `--include-deps`, which support the creation of a catalog archive
that is restricted to a specific set of packages. Also
`--fast-file-copy`, which is usefl for speeding up a pipeline of
archiving (helpful to pkg-build).
This commit is contained in:
Matthew Flatt 2020-04-12 05:24:37 -06:00
parent 1b48cd86f9
commit 5df1b7906b
9 changed files with 160 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/pkg/scribblings/lib.scrbl
View File

@ -496,6 +496,10 @@ for extracting existing catalog information.
[#:from-config? from-config? boolean? #f]
[#:state-catalog state-catalog (or/c #f path-string?) #f]
[#:relative-sources? relative-sources? boolean? #f]
[#:include includes (or/c #f (listof string?)) #f]
[#:include-deps? include-deps? boolean? #f]
[#:exclude excludes (listof string?) '()]
[#:fast-file-copy? fast-file-copy? boolean? #f]
[#:quiet? quiet? boolean? #f]
[#:package-exn-handler package-exn-handler (string? exn:fail? . -> . any) (lambda (_pkg-name _exn) (raise _exn))])
void?]{
@ -513,7 +517,9 @@ The @racket[current-pkg-lookup-version] parameter determines the version
for extracting existing catalog information.
@history[#:added "6.0.1.7"
#:changed "6.0.1.13" @elem{Added the @racket[#:package-exn-handler] argument.}]}
#:changed "6.0.1.13" @elem{Added the @racket[#:package-exn-handler] argument.}
#:changed "7.7.0.1" @elem{Added the @racket[#:include], @racket[#:include-deps?],
@racket[#:exclude], and @racket[#:fast-file-copy?] arguments.}]}
@defproc[(pkg-archive-pkgs [dest-dir path-string?]
[pkgs (listof path-string?)]

22
pkgs/racket-doc/pkg/scribblings/pkg.scrbl
View File

@ -1100,9 +1100,29 @@ for @nonterm{key}.
@item{@exec{continue} --- like @exec{skip}, but @exec{raco pkg catalog-archive}
exits with a status code of @exec{5} if any package was skipped.}
]}
@item{@DFlag{include} @nonterm{pkg} --- Can be specified multiple times. If @DFlag{include} is
specified at least once, then the archive and generated catalog includes only
the @nonterm{pkg}s specified with @DFlag{include}, plus the dependencies
of each @nonterm{pkg} if @DFlag{include-deps} is specified, modulo packages
excluded via @DFlag{exclude}.}
@item{@DFlag{include-deps} --- Modifies the @DFlag{includes} @nonterm{pkg} flag to imply all
dependencies of @nonterm{pkg}.}
@item{@DFlag{exclude} @nonterm{pkg} --- Can be specified multiple times. Removes @nonterm{pkg}
from the set of packages in the archive and generated catalog. If @DFlag{include} is
used for the same @nonterm{pkg}, then @DFlag{exclude} takes
precedence. If @DFlag{include} is used with
@DFlag{include-deps} for @nonterm{pkg} or a package that depends on @nonterm{pkg},
then @DFlag{exclude} stops the consideration of @nonterm{pkg}'s
dependencies (but does not necessarily exclude the dependencies, because they
may be dependencies of an included package).}
@item{@DFlag{fast-file-copy} --- Directly copies package files from the @nonterm{src-catalog}s
when available on the local filesystem, instead of extracting and repacking.}
]
@history[#:added "6.0.17"]
@history[#:added "6.0.17"
#:changed "7.7.0.1" @elem{Added @DFlag{include}, @DFlag{include-deps}, @DFlag{exclude},
and @DFlag{fast-file-copy}.}]
}
@subcommand{@command/toc{archive} @nonterm{option} ... @nonterm{dest-dir} @nonterm{pkg} ...

2
racket/collects/pkg/db.rkt
View File

@ -172,7 +172,7 @@
#:mode 'create
#:busy-retry-limit +inf.0))))
(lambda () (proc (or catalog-db
(make-catalog-db db #f (make-hash)))))
(make-catalog-db db #f (make-hash)))))
(lambda ()
(unless catalog-db
(disconnect db)))))

4
racket/collects/pkg/lib.rkt
View File

@ -197,6 +197,10 @@
#:state-catalog (or/c path-string? #f)
#:relative-sources? boolean?
#:quiet? boolean?
#:include (or/c #f (listof string?))
#:include-deps? boolean?
#:exclude (or/c #f (listof string?))
#:fast-file-copy? boolean?
#:package-exn-handler (string? exn:fail? . -> . any))
void?)]
[pkg-archive-pkgs

15
racket/collects/pkg/main.rkt
View File

@ -602,6 +602,7 @@
;; ----------------------------------------
[catalog-archive
"Copy catalog plus packages"
(define include-list (make-parameter #f))
#:once-each
[#:bool from-config () "Include currently configured catalogs last"]
[(#:str state-database #f) state () "Read/write <state-database> as state of <dest-dir>"]
@ -610,6 +611,16 @@
[(#:sym mode [fail skip continue] 'fail) pkg-fail ()
("Select handling of package-download failure;"
"<mode>s: fail (the default), skip, continue (but with exit status of 5)")]
#:multi
[(#:str pkg #f) include () "Include <pkg> in new catalog"
(include-list (cons pkg (or (include-list) '())))]
#:once-each
[#:bool include-deps () "Include dependencies of specified packages"]
#:multi
[(#:str pkg #f) exclude () "Exclude <pkg> from new catalog"
(exclude-list (cons pkg (exclude-list)))]
#:once-each
[#:bool fast-file-copy () "Copy a local file package as-is"]
#:args (dest-dir . src-catalog)
(parameterize ([current-pkg-error (pkg-error 'catalog-archive)]
[current-pkg-lookup-version (or version
@ -620,6 +631,10 @@
#:from-config? from-config
#:state-catalog state
#:relative-sources? relative
#:include (include-list)
#:include-deps? include-deps
#:exclude (exclude-list)
#:fast-file-copy? fast-file-copy
#:package-exn-handler (case pkg-fail
[(fail) (lambda (name exn) (raise exn))]
[(skip continue)

107
racket/collects/pkg/private/catalog-archive.rkt
View File

@ -3,22 +3,28 @@
racket/file
racket/set
openssl/sha1
"../name.rkt"
(prefix-in db: "../db.rkt")
"catalog.rkt"
"catalog-copy.rkt"
"print.rkt"
"stage.rkt"
"desc.rkt"
"create.rkt")
"create.rkt"
"path.rkt")
(provide pkg-catalog-archive)
(define (pkg-catalog-archive dest-dir
src-catalogs
#:include [include-names #f]
#:include-deps? [include-deps? #f]
#:exclude [exclude-names '()]
#:from-config? [from-config? #f]
#:state-catalog [state-catalog #f]
#:relative-sources? [relative-sources? #f]
#:quiet? [quiet? #f]
#:fast-file-copy? [fast-file-copy? #f]
#:package-exn-handler [package-exn-handler (lambda (name exn) (raise exn))])
(when (and state-catalog
(not (db-path? (if (path? state-catalog)
@ -36,8 +42,12 @@
#:force? #t ; replaces temporary file
#:from-config? from-config?)
(define pkgs
(parameterize ([db:current-pkg-catalog-file temp-catalog-file])
(db:get-pkgs)))
(filter-pkgs
(parameterize ([db:current-pkg-catalog-file temp-catalog-file])
(db:get-pkgs))
include-names include-deps?
(cons "racket" exclude-names)
temp-catalog-file))
;; Reset state catalog to new packages:
(when state-catalog
(parameterize ([db:current-pkg-catalog-file state-catalog])
@ -75,21 +85,39 @@
(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 #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))
(define-values (staged-checksum)
(cond
[(and fast-file-copy?
(let ([src (db:pkg-source pkg)])
(let-values ([(name type) (package-source->name+type src #f)])
(case type
[(file) (package-source->path src 'file)]
[else #f]))))
=> (lambda (path)
(define-values (base filename dir) (split-path path))
(make-directory* (build-path dest-dir "pkgs"))
(copy-file path (build-path dest-dir "pkgs" filename) #t)
(copy-file (path-add-checksum-suffix path)
(build-path dest-dir "pkgs" (path-add-checksum-suffix filename))
#t)
(values (db:pkg-checksum pkg)))]
[else
;; 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 #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))
(values staged-checksum)]))
;; Record packed result:
(when state-catalog
(parameterize ([db:current-pkg-catalog-file state-catalog])
@ -121,5 +149,46 @@
(build-path dest-dir "catalog")
#:force? #t
#:override? #t
#:relative-sources? relative-sources?)
#:relative-sources? relative-sources?
#:include-only (map db:pkg-name pkgs))
(delete-file temp-catalog-file))
;; ----------------------------------------
(define (filter-pkgs pkgs include-names include-deps? exclude-names catalog)
(cond
[(not include-names)
(if (null? exclude-names)
pkgs
(for/list ([pkg (in-list pkgs)]
#:unless (member (db:pkg-name pkg) exclude-names))
pkg))]
[else
(define pkg-map (for/hash ([pkg (in-list pkgs)])
(values (db:pkg-name pkg) pkg)))
(define include-table
(let loop ([include-table #hash()]
[todo-names include-names])
(cond
[(null? todo-names) include-table]
[else
(let ([name (car todo-names)])
(cond
[(or (hash-ref include-table name #f)
(member name exclude-names))
(loop include-table (cdr todo-names))]
[else
(loop (hash-set include-table name #t)
(append
(if include-deps?
(let ([pkg (hash-ref pkg-map name)])
(map car
(parameterize ([db:current-pkg-catalog-file catalog])
(db:get-pkg-dependencies name
(db:pkg-catalog pkg)
(db:pkg-checksum pkg)))))
null)
(cdr todo-names)))]))])))
(for/list ([pkg (in-list pkgs)]
#:when (hash-ref include-table (db:pkg-name pkg) #f))
pkg)]))

23
racket/collects/pkg/private/catalog-copy.rkt
View File

@ -35,7 +35,8 @@
#:merge? [merge? #f]
#:force? [force? #f]
#:override? [override? #f]
#:relative-sources? [relative-sources? #f])
#:relative-sources? [relative-sources? #f]
#:include-only [include-names #f])
(define src-paths
(for/list ([src (in-list (append srcs
(if from-config?
@ -82,6 +83,11 @@
" path: ~a")
dest-path)))
(define include-table
(and include-names
(for/hash ([name (in-list include-names)])
(values name #t))))
(define absolute-details
(let ([src-paths (if (and merge?
(or (file-exists? dest-path)
@ -98,10 +104,17 @@
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))
(cond
[relative-sources?
(for/hash ([(k ht) (in-hash absolute-details)]
#:when (hash-ref include-table k #f))
(values k (source->relative-source dest-dir ht)))]
[include-table
(for/hash ([(k ht) (in-hash absolute-details)]
#:when (hash-ref include-table k #f))
(values k ht))]
[else
absolute-details]))
(when (and force? (not merge?))
(cond

1
racket/collects/pkg/private/create.rkt
View File

@ -100,6 +100,7 @@
(apply zip pkg/complete content
#:path-prefix (and (add-directory-layer? content)
pkg-name)
#:system-type 'unix ; for consistency across platforms
#:get-timestamp file-or-directory-timestamp
#:utc-timestamps? #t
#:round-timestamps-down? #t)))]

5
racket/collects/pkg/private/path.rkt
View File

@ -37,6 +37,11 @@
(string->symbol (regexp-replace #rx"[.]rkt$" (cadr mod) ""))
mod))
(define (path-add-checksum-suffix path)
(if (string? path)
(string-append path ".CHECKSUM")
(bytes->path (bytes-append (path->bytes path) #".CHECKSUM"))))
(define (lift-directory-content pkg-dir path)
(define orig-sub (let ([s (car path)])
(if (string? s)