diff --git a/collects/planet2/lib.rkt b/collects/planet2/lib.rkt index b732058cb6..de35b71b20 100644 --- a/collects/planet2/lib.rkt +++ b/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) - (make-directory* (pkg-dir)) - (call-with-file-lock/timeout - #f 'exclusive - t - (λ () (pkg-error (~a "could not acquire package lock\n" - " lock file: ~a") - (pkg-lock-file))) - #:lock-file (pkg-lock-file))) +(define (with-package-lock* read-only? t) + (define d (pkg-dir)) + (unless read-only? (make-directory* d)) + (if (directory-exists? d) + ;; If the directory exists, assume that a lock file is + ;; available or creatable: + (call-with-file-lock/timeout + #f (if read-only? 'shared 'exclusive) + 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?)] diff --git a/collects/planet2/main.rkt b/collects/planet2/main.rkt index 151faba4fd..10539ec572 100644 --- a/collects/planet2/main.rkt +++ b/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 - (config-cmd set key/val))))] + (if set + (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 diff --git a/collects/tests/planet2/test.rkt b/collects/tests/planet2/test.rkt index fa3d3c1ce8..fb007eff1c 100644 --- a/collects/tests/planet2/test.rkt +++ b/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" diff --git a/collects/tests/planet2/tests-permissions.rkt b/collects/tests/planet2/tests-permissions.rkt new file mode 100644 index 0000000000..b1799bbab0 --- /dev/null +++ b/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))))