raco pkg: allow read operations on read-only package data

In particular, `raco pkg show' should work when the user does not
have write access to the installation directory or installation-wide
package database.

Merge to v5.3.2
(cherry picked from commit b5d874e35d)

collects/planet2/lib.rkt

@@ -35,6 +35,8 @@
   (make-parameter (version)))
 (define current-pkg-error
   (make-parameter (lambda args (apply error 'pkg args))))
+(define current-no-pkg-db
+  (make-parameter #f))
 
 (define (pkg-error . rest)
   (apply (current-pkg-error) rest))
@@ -185,17 +187,28 @@
       #f
       (cadr dep)))
 
-(define (with-package-lock* t)
+(define (with-package-lock* read-only? t)
-  (make-directory* (pkg-dir))
+  (define d (pkg-dir))
-  (call-with-file-lock/timeout
+  (unless read-only? (make-directory* d))
-   #f 'exclusive
+  (if (directory-exists? d)
-   t
+      ;; If the directory exists, assume that a lock file is
-   (λ () (pkg-error  (~a "could not acquire package lock\n"
+      ;; available or creatable:
-                        "  lock file: ~a")
+      (call-with-file-lock/timeout
-                    (pkg-lock-file)))
+       #f (if read-only? 'shared 'exclusive)
-   #:lock-file (pkg-lock-file)))
+       t
+       (λ () (pkg-error  (~a "could not acquire package lock\n"
+                             "  lock file: ~a")
+                         (pkg-lock-file)))
+       #:lock-file (pkg-lock-file))
+      ;; Directory does not exist; we must be in read-only mode.
+      ;; Run `t' under the claim that no database is available
+      ;; (in case the database is created concurrently):
+      (parameterize ([current-no-pkg-db #t])
+        (t))))
 (define-syntax-rule (with-package-lock e ...)
-  (with-package-lock* (λ () e ...)))
+  (with-package-lock* #f (λ () e ...)))
+(define-syntax-rule (with-package-lock/read-only e ...)
+  (with-package-lock* #t (λ () e ...)))
 
 (define (maybe-append lists)
   (and (for/and ([v (in-list lists)]) (not (eq? v 'all)))
@@ -253,7 +266,9 @@
     (λ () (write new-db))))
 
 (define (read-pkg-db)
-  (read-file-hash (pkg-db-file)))
+  (if (current-no-pkg-db)
+      #hash()
+      (read-file-hash (pkg-db-file))))
 
 (define (package-info pkg-name [fail? #t])
   (define db (read-pkg-db))
@@ -1154,6 +1169,7 @@
 
 (provide
  with-package-lock
+ with-package-lock/read-only
  (contract-out
   [current-install-system-wide?
    (parameter/c boolean?)]

collects/planet2/main.rkt

@@ -187,7 +187,7 @@
                      [current-install-version-specific? (eq? mode 'u)]
                      [current-pkg-error (pkg-error 'show)]
                      [current-show-version (or version (r:version))])
-        (with-package-lock
+        (with-package-lock/read-only
          (show-cmd (if only-mode "" " "))))))]
  [config
   "View and modify the package configuration"
@@ -207,8 +207,11 @@
    'config
    scope installation shared user
    (lambda ()
-     (with-package-lock
+     (if set
-      (config-cmd set key/val))))]
+         (with-package-lock
+          (config-cmd #t key/val))
+         (with-package-lock/read-only
+          (config-cmd #f key/val)))))]
  [create
   "Bundle a new package"
   #:once-any

collects/tests/planet2/test.rkt

@@ -2,7 +2,9 @@
 (require (for-syntax racket/base
                      "util.rkt")
          "shelly.rkt"
-         "util.rkt")
+         "util.rkt"
+         racket/port
+         (only-in planet2 config))
 
 ;; By making these syntax-time includes, it made it so they would be
 ;; rebuilt and register as real dependencies.
@@ -27,9 +29,17 @@
      (shelly-case "All tests"
                   (for-each (λ (x) (x)) l)))))
 
+(let ([v (getenv "PLT_PLANET2_NOSETUP")])
+  (unless (and v (not (string=? v "")))
+    (error "Set the PLT_PLANET2_NOSETUP environment variable before running these tests\n")))
+
+(unless (equal? "user\n" (with-output-to-string
+                          (lambda () (config #:installation #t "default-scope"))))
+  (error "Run this test suite with `user' default package scope"))
+
 (run-tests
  "name"
- "basic" "create" "install"
+ "basic" "create" "install" "permissions"
  "network" "conflicts" "checksums"
  "deps" "update" 
  "remove"

collects/tests/planet2/tests-permissions.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+(require "shelly.rkt"
+         "util.rkt")
+
+(pkg-tests
+ (define dir (getenv "PLTADDONDIR"))
+ (define pkg-dir (build-path dir "pkgs"))
+ (define (try-now)
+   (shelly-case
+    "Should be able to read information that is read-only"
+    (define old-dir-perms (and (directory-exists? dir)
+                               (file-or-directory-permissions dir 'bits)))
+    (define old-pkg-dir-perms (and (directory-exists? pkg-dir)
+                                   (file-or-directory-permissions pkg-dir 'bits)))
+    (when old-pkg-dir-perms
+      (file-or-directory-permissions pkg-dir 0))
+    (when old-dir-perms
+      (file-or-directory-permissions dir 0))
+    $ "raco pkg show"
+    (when old-dir-perms
+      (file-or-directory-permissions dir old-dir-perms))
+    (when old-pkg-dir-perms
+      (file-or-directory-permissions pkg-dir old-pkg-dir-perms))))
+
+ (try-now)
+
+ (if (directory-exists? pkg-dir)
+     ;; move the directory and try again:
+     (let ([alt-dir (build-path dir "xpkgs")])
+       (rename-file-or-directory pkg-dir alt-dir)
+       (try-now)
+       (rename-file-or-directory alt-dir pkg-dir))
+     ;; create the directory and try again:
+     (begin
+       (make-directory pkg-dir)
+       (try-now))))