diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 97e0de1401..2bb30642a5 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -1079,12 +1079,12 @@ ['github (unless checksum (pkg-error - (~a "could not find checksum for github package source, which implies it doesn't exist\n" + (~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" + (~a "cannot use empty checksum for GitHub package source\n" " source: ~a") pkg)) (match-define (list* user repo branch path) @@ -1108,8 +1108,6 @@ "~a-" (format "~a.~a" repo branch)) 'directory)) - (define package-path - (apply build-path tmp-dir path)) (dynamic-wind void @@ -1122,8 +1120,17 @@ 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 (path->string package-path) + (stage-package/info tmp-dir 'dir pkg-name #:given-checksum checksum @@ -1133,13 +1140,13 @@ download-printf metadata-ns #:strip strip-mode - #:in-place? (not strip-mode) + #:in-place? #t #:in-place-clean? #t) (set! staged? #t))) (λ () (when (and use-cache? (not staged?)) (clean-cache new-url checksum)) - (unless (and staged? (not strip-mode)) + (unless staged? (delete-directory/files tmp-dir))))) (λ () (delete-directory/files tmp.tgz)))] @@ -1269,7 +1276,7 @@ (define pkg-dir (make-temporary-file (string-append "~a-" pkg-name) 'directory)) - (define staged? #t) + (define staged? #f) (dynamic-wind void (λ () diff --git a/racket/collects/pkg/util.rkt b/racket/collects/pkg/util.rkt index aba23d796a..bb282ea597 100644 --- a/racket/collects/pkg/util.rkt +++ b/racket/collects/pkg/util.rkt @@ -7,6 +7,7 @@ racket/match racket/format racket/string + racket/set net/url json) @@ -163,4 +164,35 @@ (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))) + (provide (all-defined-out))