pkg/lib: lock clean-up, and add `path->pkg'

mflatt · mflatt · commit 10e53e3bf4e1 · 2013-04-16T08:58:19.000-06:00
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.
diff --git 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
@@ -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
@@ -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,15 +175,19 @@ 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?)]
                           [#:auto? auto? boolean? #f]
                           [#: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
@@ -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)))))
