From 10e53e3bf4e18d40f97213911b0b9c8bb56fd09f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Apr 2013 08:49:22 -0600 Subject: [PATCH] pkg/lib: lock clean-up, and add `path->pkg' Make the installed-package database lock reentrant, change some functions to take the lock, and fix the documentation on when a lock is expected to be taken outside of functions. --- collects/compiler/commands/test.rkt | 11 ++- collects/pkg/lib.rkt | 104 ++++++++++++++++++++------- collects/pkg/scribblings/lib.scrbl | 39 +++++++--- collects/tests/pkg/tests-install.rkt | 6 ++ 4 files changed, 116 insertions(+), 44 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index c42a5eabb4..381498b9ff 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -108,13 +108,10 @@ [l (for-each do-test l)])] [packages? - (unless (for*/or ([scope (in-list '(installation user shared))]) - (define pd - (parameterize ([current-pkg-scope scope]) - (with-handlers ([exn:fail? (λ (x) #f)]) - (pkg-directory e)))) - (and pd (do-test pd))) - (error 'test "Package ~e is not installed" e))] + (define pd (pkg-directory e)) + (if pd + (do-test pd) + (error 'test "Package ~e is not installed" e))] [else (do-test e)])) diff --git a/collects/pkg/lib.rkt b/collects/pkg/lib.rkt index b792397182..010baeabbf 100644 --- a/collects/pkg/lib.rkt +++ b/collects/pkg/lib.rkt @@ -232,24 +232,35 @@ (equal? p s)))) #t)) +(define pkg-lock-held (make-parameter #f)) + (define (with-pkg-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 mode (if read-only? 'shared 'exclusive)) + (define held-mode (pkg-lock-held)) + (if (or (eq? mode held-mode) + (eq? 'exclusive held-mode)) + (t) + (let ([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 + mode + (lambda () + (parameterize ([pkg-lock-held mode]) + (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]) + (parameterize ([pkg-lock-held mode]) + (t))))))) (define-syntax-rule (with-pkg-lock e ...) (with-pkg-lock* #f (λ () e ...))) (define-syntax-rule (with-pkg-lock/read-only e ...) @@ -269,7 +280,8 @@ "https://planet-compat.racket-lang.org")])))) (define (pkg-config-indexes) - (read-pkg-cfg/def "indexes")) + (with-pkg-lock/read-only + (read-pkg-cfg/def "indexes"))) (define (pkg-indexes) (or (current-pkg-indexes) @@ -449,8 +461,9 @@ [else 'user])) (define (default-pkg-scope-as-string) (parameterize ([current-pkg-scope 'installation]) - (define cfg (read-pkg-cfg)) - (hash-ref cfg "default-scope" "user"))) + (with-pkg-lock/read-only + (define cfg (read-pkg-cfg)) + (hash-ref cfg "default-scope" "user")))) (struct pkg-info (orig-pkg checksum auto?) #:prefab) (struct install-info (name orig-pkg directory clean? checksum)) @@ -463,13 +476,48 @@ [checksum op])) (define (pkg-directory pkg-name) - (match-define (pkg-info orig-pkg checksum _) - (package-info pkg-name)) - (match orig-pkg - [`(link ,orig-pkg-dir) - orig-pkg-dir] - [_ - (build-path (pkg-installed-dir) pkg-name)])) + (for/or ([scope (in-list '(user shared installation))]) + (parameterize ([current-pkg-scope scope]) + (with-pkg-lock/read-only + (define info (package-info pkg-name #f)) + (and info + (let () + (match-define (pkg-info orig-pkg checksum _) info) + (match orig-pkg + [`(link ,orig-pkg-dir) + orig-pkg-dir] + [_ + (build-path (pkg-installed-dir) pkg-name)]))))))) + +(define (path->pkg given-p) + (define (explode p) + (explode-path + (normal-case-path + (simple-form-path p)))) + (define (sub-path? < p d) + (and ((length d) . <= . (length p)) + (for/and ([de (in-list d)] + [pe (in-list p)]) + (equal? de pe)))) + (define p (explode given-p)) + (for/or ([scope (in-list '(user shared installation))]) + (parameterize ([current-pkg-scope scope]) + (with-pkg-lock/read-only + (define d (explode (pkg-installed-dir))) + (cond + [(sub-path? < p d) + ;; Under the installation mode's package directory. + ;; We assume that no one else writes there, so the + ;; next path element is the package name. + (path-element->string (list-ref p (length d)))] + [else + ;; Maybe it's a linked package + (for/or ([(k v) (in-hash (read-pkg-db))]) + (match (pkg-info-orig-pkg v) + [`(link ,orig-pkg-dir) + (and (sub-path? <= p (explode orig-pkg-dir)) + k)] + [else #f]))]))))) (define (remove-package pkg-name) (printf "Removing ~a\n" pkg-name) @@ -1666,6 +1714,8 @@ (parameter/c (or/c #f (listof url?)))] [pkg-directory (-> string? path-string?)] + [path->pkg + (-> path-string? (or/c #f string?))] [pkg-desc (-> string? (or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name) diff --git a/collects/pkg/scribblings/lib.scrbl b/collects/pkg/scribblings/lib.scrbl index 1ca24a807c..86d42ec672 100644 --- a/collects/pkg/scribblings/lib.scrbl +++ b/collects/pkg/scribblings/lib.scrbl @@ -21,12 +21,14 @@ commands are built.} )]{ Evaluates the @racket[body]s while holding a lock to prevent -concurrent modification to the package database. Use the -@racket[with-pkg-lock/read-only] form for read-only access. +concurrent modification to the package database for the current +@tech{package scope}. Use the @racket[with-pkg-lock/read-only] form +for read-only access. The lock is reentrant but not upgradable from +read-only. Use these form to wrap uses of functions from @racketmodname[pkg/lib] -that read or modify the package database.} - +that are documented to require the lock. Other functions from +@racketmodname[pkg/lib] take the lock as needed.} @deftogether[( @defparam[current-pkg-scope scope (or/c 'installation 'user 'shared)] @@ -76,7 +78,12 @@ A structure type that is used to report installed-package information.} @defproc[(pkg-directory [name string?]) path-string?]{ Returns the directory that holds the installation of the installed -package @racket[name].} +(in any scope) package @racket[name].} + + +@defproc[(path->pkg [path path-string?]) (or/c string? #f)]{ + +Returns the installed package containing @racket[path], if any.} @defproc[(default-pkg-scope) (or/c 'installation 'user 'shared)]{ @@ -131,7 +138,10 @@ needed.} @defproc[(pkg-config [set? boolean?] [keys/vals list?]) void?]{ -Implements the @racket[config] command.} +Implements the @racket[config] command. + +The package lock must be held (allowing writes if @racket[set?] is true); see +@racket[with-pkg-lock].} @defproc[(pkg-create [format (or/c 'zip 'tgz 'plt 'MANIFEST)] @@ -151,7 +161,9 @@ Implements the @racket[create] command.} Implements the @racket[install] command. The result indicates which collections should be setup via @exec{raco setup}: @racket[#f] means -all, and a list means only the indicated collections.} +all, and a list means only the indicated collections. + +The package lock must be held; see @racket[with-pkg-lock].} @defproc[(pkg-update [names (listof string?)] @@ -163,7 +175,9 @@ all, and a list means only the indicated collections.} (or/c #f (listof (or/c path-string? (non-empty-listof path-string?))))]{ Implements the @racket[update] command. The result is the same as for -@racket[install-pkgs].} +@racket[install-pkgs]. + +The package lock must be held; see @racket[with-pkg-lock].} @defproc[(pkg-remove [names (listof string?)] @@ -171,7 +185,9 @@ Implements the @racket[update] command. The result is the same as for [#:force? force? boolean? #f]) void?]{ -Implements the @racket[remove] command.} +Implements the @racket[remove] command. + +The package lock must be held; see @racket[with-pkg-lock].} @defproc[(pkg-show [indent string?] @@ -180,7 +196,10 @@ Implements the @racket[remove] command.} Implements the @racket[show] command for a single package scope, printing to the current output port. See also -@racket[installed-pkg-names] and @racket[installed-pkg-table].} +@racket[installed-pkg-names] and @racket[installed-pkg-table]. + +The package lock must be held to allow reads; see +@racket[with-pkg-lock/read-only].} @defproc[(pkg-index-show [names (listof string?)] diff --git a/collects/tests/pkg/tests-install.rkt b/collects/tests/pkg/tests-install.rkt index 63f9f4ead1..123371308d 100644 --- a/collects/tests/pkg/tests-install.rkt +++ b/collects/tests/pkg/tests-install.rkt @@ -83,6 +83,9 @@ $ "raco pkg install --link test-pkgs/pkg-test1-linking" $ "racket -e '(require pkg-test1)'" $ "racket -e '(require pkg-test1/a)'" =exit> 1 + $ "racket -e '(require pkg/lib)' -e '(path->pkg \"test-pkgs/pkg-test1-linking\")'" =stdout> "\"pkg-test1-linking\"\n" + $ "racket -e '(require pkg/lib)' -e '(path->pkg \"test-pkgs/pkg-test1-linking/README\")'" =stdout> "\"pkg-test1-linking\"\n" + $ "racket -e '(require pkg/lib)' -e '(path->pkg \"test-pkgs\")'" =stdout> "#f\n" $ "cp test-pkgs/pkg-test1-staging/a.rkt test-pkgs/pkg-test1-linking/pkg-test1/a.rkt" $ "racket -e '(require pkg-test1/a)'" $ "rm -f test-pkgs/pkg-test1-linking/pkg-test1/a.rkt" @@ -116,5 +119,8 @@ $ "raco pkg install --deps search-auto pkg-test2-snd" $ "racket -e '(require pkg-test1)'" $ "racket -e '(require pkg-test2)'" + $ "racket -e '(require pkg/lib)' -e '(path->pkg (pkg-directory \"pkg-test1\"))'" =stdout> "\"pkg-test1\"\n" + $ "racket -e '(require pkg/lib)' -e '(path->pkg (build-path (pkg-directory \"pkg-test1\") \"pkg-test2\"))'" + =stdout> "\"pkg-test1\"\n" $ "raco pkg remove pkg-test2-snd pkg-test1" $ "racket -e '(require pkg-test1)'" =exit> 1)))))