raco pkg install: fix tmp-directory clean-up

Fix when installing from a non-directory in `--source` or
`--binary` mode, and fix clean up of a GitHub-generated archive
when using a path within the archive.

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
         (λ ()

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))