From 5df1b7906bb0e81ce56ccd84efb364fa4b050366 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Apr 2020 05:24:37 -0600 Subject: [PATCH] raco pkg archive-catalog: add `--include` and `--exclude` 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). --- pkgs/racket-doc/pkg/scribblings/lib.scrbl | 8 +- pkgs/racket-doc/pkg/scribblings/pkg.scrbl | 22 +++- racket/collects/pkg/db.rkt | 2 +- racket/collects/pkg/lib.rkt | 4 + racket/collects/pkg/main.rkt | 15 +++ .../collects/pkg/private/catalog-archive.rkt | 107 ++++++++++++++---- racket/collects/pkg/private/catalog-copy.rkt | 23 +++- racket/collects/pkg/private/create.rkt | 1 + racket/collects/pkg/private/path.rkt | 5 + 9 files changed, 160 insertions(+), 27 deletions(-) diff --git a/pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-doc/pkg/scribblings/lib.scrbl index fbf54f2466..6059f0f6d8 100644 --- a/pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -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?)] diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl index b1bb5b0a4c..37ffe39bf9 100644 --- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -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} ... diff --git a/racket/collects/pkg/db.rkt b/racket/collects/pkg/db.rkt index 0f30d96e6d..9e9bb105f7 100644 --- a/racket/collects/pkg/db.rkt +++ b/racket/collects/pkg/db.rkt @@ -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))))) diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 8370522425..7058849469 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -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 diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 17e9086f6b..1b98d194ff 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -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 as state of "] @@ -610,6 +611,16 @@ [(#:sym mode [fail skip continue] 'fail) pkg-fail () ("Select handling of package-download failure;" "s: fail (the default), skip, continue (but with exit status of 5)")] + #:multi + [(#:str pkg #f) include () "Include 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 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) diff --git a/racket/collects/pkg/private/catalog-archive.rkt b/racket/collects/pkg/private/catalog-archive.rkt index d27d288aa0..fba9fb0321 100644 --- a/racket/collects/pkg/private/catalog-archive.rkt +++ b/racket/collects/pkg/private/catalog-archive.rkt @@ -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)])) diff --git a/racket/collects/pkg/private/catalog-copy.rkt b/racket/collects/pkg/private/catalog-copy.rkt index 797471f153..0414149f8e 100644 --- a/racket/collects/pkg/private/catalog-copy.rkt +++ b/racket/collects/pkg/private/catalog-copy.rkt @@ -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 diff --git a/racket/collects/pkg/private/create.rkt b/racket/collects/pkg/private/create.rkt index ff1d6b5d51..7c8d21c216 100644 --- a/racket/collects/pkg/private/create.rkt +++ b/racket/collects/pkg/private/create.rkt @@ -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)))] diff --git a/racket/collects/pkg/private/path.rkt b/racket/collects/pkg/private/path.rkt index ad302b1a27..6fdbf08691 100644 --- a/racket/collects/pkg/private/path.rkt +++ b/racket/collects/pkg/private/path.rkt @@ -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)