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

Add raco pkg archive.

Browse Source 
This creates a catalog from the specified currently-installed
packages. The catalog can then be used to replicate some or
all of the currently-installed packages in another installation
or other context.

Also extend `pkg/command` so that `#:multi` is useful.
This commit is contained in:
Sam Tobin-Hochstadt 2014-08-31 01:52:42 -04:00 committed by Sam Tobin-Hochstadt
parent 3d75c8ce71
commit 837abdd51a
7 changed files with 270 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl
View File

@ -41,8 +41,9 @@ to the @exec{raco pkg} sub-subcommands.
@defthing[pkg-catalog-show-command procedure?]{Implements @command-ref{catalog-show}.}
@defthing[pkg-catalog-copy-command procedure?]{Implements @command-ref{catalog-copy}.}
@defthing[pkg-catalog-archive-command procedure?]{Implements @command-ref{catalog-archive}.
@history[#:added "6.0.17"]}
@defthing[pkg-archive-command procedure?]{Implements @command-ref{archive}.
@history[#:added "6.1.0.8"]}
@include-section["lib.scrbl"]
@include-section["path.scrbl"]

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

@ -397,6 +397,26 @@ for extracting existing catalog information.
@history[#:added "6.0.1.7"
#:changed "6.0.1.13" @elem{Added the @racket[#:package-exn-handler] argument.}]}
@defproc[(pkg-archive-pkgs [dest-dir path-string?]
[pkgs (listof path-string?)]
[#:include-deps? include-deps? boolean? #f]
[#:exclude exclude (listof string?) null]
[#:relative-sources? relative-sources? boolean? #f]
[#:quiet? quiet? boolean? #f]
[#:package-exn-handler package-exn-handler (string? exn:fail? . -> . any) (lambda (_pkg-name _exn) (raise _exn))])
void?]{
Implements @racket[pkg-archive-command].
The @racket[package-exn-handler] argument handles any exception that
is raised while trying to archive an individual package; the first
argument is the package name, and the second is the exception. The
default re-@racket[raise]s the exception, which aborts the archiving
process, while a function that logs the exception message and returns
would allow archiving to continue for other packages.
@history[#:added "6.1.0.8"]}
@defproc[(pkg-catalog-update-local [#:catalogs catalogs (listof string?) (pkg-config-catalogs)]
[#:catalog-file catalog-file path-string? (current-pkg-catalog-file)]

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

@ -749,6 +749,31 @@ for @nonterm{key}.
@history[#:added "6.0.17"]
}
@subcommand{@command/toc{archive} @nonterm{option} ... @nonterm{dest-dir} @nonterm{pkg} ...
--- Copies information from installed packages named by @nonterm{pkgs}s
to a @filepath{catalog} directory catalog in @nonterm{dest-dir}, and also copies
all package sources to a @filepath{pkgs} directory in @nonterm{dest-dir}.
Packages sources are copied and repacked as needed, so that
all packages are written to the @filepath{pkgs} directory as
@filepath{.zip} archives. This conversion may change the checksum
on each archived package.
The @exec{archive} sub-command accepts
the following @nonterm{option}s:
@itemlist[
@item{@DFlag{include-deps} --- Includes the dependencies of the specified packages
in the resulting catalog.}
@item{@DFlag{exclude} @nonterm{pkg} --- Omits the specified @nonterm{pkg} from the
resulting catalog. This also causes the dependencies of @nonterm{pkg} to be
omitted if @DFlag{include-deps} is specified. This flag can be provided multiple times.}
@item{@DFlag{relative} --- Write package sources to @nonterm{dest-catalog} in relative-path form.}
]
@history[#:added "6.1.0.8"]
}
@; ----------------------------------------
@section[#:tag "metadata"]{Package Metadata}

32
pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt
View File

@ -84,8 +84,10 @@
123)))
o))))
(add-whale! "345")
$ (~a "raco pkg catalog-show --catalog file://" (path->string dir2) " whale") =stdout> #rx"Checksum: 345"
$ (~a "raco pkg catalog-show --version 5.3.6 --catalog file://" (path->string dir2) " whale") =stdout> #rx"Checksum: 123"
$ (~a "raco pkg catalog-show --catalog file://" (path->string dir2) " whale")
=stdout> #rx"Checksum: 345"
$ (~a "raco pkg catalog-show --version 5.3.6 --catalog file://" (path->string dir2) " whale")
=stdout> #rx"Checksum: 123"
$ "raco pkg catalog-show whale" =exit> 1
$ (~a "raco pkg catalog-copy --merge " (path->string dir2) " " (path->string dest))
@ -155,4 +157,30 @@
$ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip") =exit> 1
$ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip.CHECKSUM") =exit> 1
;; archive
(delete-directory/files archive-d)
$ (~a "raco pkg install pkg-test1")
$ (~a "raco pkg archive " archive-d " pkg-test1")
=stdout> #rx"== Archiving pkg-test1 =="
$ (~a "test -f " archive-d "/pkgs/pkg-test1.zip")
$ (~a "test -f " archive-d "/pkgs/pkg-test1.zip.CHECKSUM")
$ "raco pkg install pkg-test2"
$ (~a "raco pkg archive " archive-d " pkg-test2")
=stdout> #rx"removing .* pkg-test1"
$ (~a "test -f " archive-d "/pkgs/pkg-test2.zip")
$ (~a "test -f " archive-d "/pkgs/pkg-test2.zip.CHECKSUM")
(delete-directory/files archive-d)
$ (~a "raco pkg archive --include-deps " archive-d " pkg-test2")
=stdout> #rx"Archiving pkg-test1" ;; checking dependencies
$ (~a "test -f " archive-d "/pkgs/pkg-test1.zip")
$ (~a "test -f " archive-d "/pkgs/pkg-test1.zip.CHECKSUM")
$ (~a "test -f " archive-d "/pkgs/pkg-test2.zip")
$ (~a "test -f " archive-d "/pkgs/pkg-test2.zip.CHECKSUM")
(delete-directory/files d)))

12
racket/collects/pkg/commands.rkt
View File

@ -59,7 +59,7 @@
(define-syntax-class option
#:attributes (command-line variable (param 1) (call 1))
[pattern (k:kind arg:id (alias:str ...) doc:expr)
[pattern (k:kind arg:id (alias:str ...) doc:expr body:expr ...)
#:do
[(define arg-kw (symbol->keyword (syntax->datum #'arg)))
(define arg-str (format "--~a" (syntax->datum #'arg)))
@ -80,7 +80,8 @@
[(alias ... #,arg-str)
k.arg-val ...
doc
(set! #,arg-var (k.fun k.arg-val ...))])])
(set! #,arg-var (k.fun k.arg-val ...))
body ...])])
(define-syntax-class group-kind
[pattern #:once-any]
@ -127,8 +128,10 @@
help-strs:expr)])
(define-syntax-class command
#:attributes (name function variables command-line)
[pattern (name:id doc:expr uh:usage-help ... og:option-group ... arg:arguments)
#:attributes (name function variables command-line (extra-defs 1))
#:literals (define)
[pattern (name:id doc:expr (~and extra-defs (define x e)) ...
uh:usage-help ... og:option-group ... arg:arguments)
#:do
[(define name-str (symbol->string (syntax->datum #'name)))]
#:attr function
@ -172,6 +175,7 @@
(syntax->list #'(c.name ...)))])
(syntax/loc stx
(begin
c.extra-defs ... ...
c.function ...
(provide (rename-out export-names ...))
(module+ main

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

@ -3668,6 +3668,164 @@
(map db:pkg-name (append pkgs more-pkgs))))
string<?)))
null))
(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))
(define dep-behavior/c
(or/c #f 'fail 'force 'search-ask 'search-auto))
@ -3803,6 +3961,14 @@
#:quiet? boolean?
#:package-exn-handler (string? exn:fail? . -> . any))
void?)]
[pkg-archive-pkgs
(->* (path-string? (listof string?))
(#:include-deps? boolean?
#:exclude (listof string?)
#:relative-sources? boolean?
#:quiet? boolean?
#:package-exn-handler (string? exn:fail? . -> . any))
void?)]
[default-pkg-scope
(-> package-scope/c)]
[installed-pkg-names

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

@ -485,7 +485,25 @@
src-catalog
#:from-config? from-config
#:state-catalog state
#:relative-sources? relative))]))]))
#:relative-sources? relative))]
;; ----------------------------------------
[archive
"Create catalog from installed packages"
(define exclude-list (make-parameter null))
#: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 relative () "Make source paths relative when possible"]
#:args (dest-dir pkg . pkgs)
(parameterize ([current-pkg-error (pkg-error 'pkgs-archive)])
(pkg-archive-pkgs dest-dir
(cons pkg pkgs)
#:include-deps? include-deps
#:exclude (exclude-list)
#:relative-sources? relative))]))]))
(make-commands
#:scope-flags
([(#:sym scope [installation user] #f) scope ()