fix bugs in the file locking protocol for planet packages
(in particular, support re-entrancy)
This commit is contained in:
Robby Findler
parent
d185c2a0df
commit
5455a16f47
|
|
@ -20,7 +20,7 @@
|
|||
|
||||
;; get/linkage : pkg-getter [see ../resolver.rkt]
|
||||
;; getter for the linkage table
|
||||
(define (get/linkage rmp pkg-specifier success-k failure-k)
|
||||
(define (get/linkage rmp pkg-specifier load? success-k failure-k)
|
||||
(let ([linked-pkg (get-linkage rmp pkg-specifier)])
|
||||
(if linked-pkg
|
||||
(success-k linked-pkg)
|
||||
|
|
|
|||
|
|
@ -76,9 +76,8 @@ Various common pieces of code that both the client and server need to access
|
|||
assoc-table-row->type
|
||||
|
||||
check/take-installation-lock
|
||||
installed-successfully?
|
||||
release-installation-lock
|
||||
dir->successful-installation-file
|
||||
dir->unpacked-file
|
||||
dir->metadata-files)
|
||||
|
||||
; ==========================================================================================
|
||||
|
|
@ -106,15 +105,15 @@ Various common pieces of code that both the client and server need to access
|
|||
; lookup-package : FULL-PKG-SPEC [path (optional)] -> PKG | #f
|
||||
; returns the directory pointing to the appropriate package in the cache, the user's hardlink table,
|
||||
; or #f if the given package isn't in the cache or the hardlink table
|
||||
(define (lookup-package pkg [dir (CACHE-DIR)] #:check-success? [check-success? #f])
|
||||
(define at (build-assoc-table pkg dir check-success?))
|
||||
(define (lookup-package pkg [dir (CACHE-DIR)] #:to-check [to-check #f])
|
||||
(define at (build-assoc-table pkg dir to-check))
|
||||
(get-best-match at pkg))
|
||||
|
||||
; build-assoc-table : FULL-PKG-SPEC path -> assoc-table
|
||||
; returns a version-number -> directory association table for the given package
|
||||
(define (build-assoc-table pkg dir check-success?)
|
||||
(define (build-assoc-table pkg dir to-check)
|
||||
(append
|
||||
(pkg->assoc-table pkg dir check-success?)
|
||||
(pkg->assoc-table pkg dir to-check)
|
||||
(hard-links pkg)))
|
||||
|
||||
|
||||
|
|
@ -161,7 +160,7 @@ Various common pieces of code that both the client and server need to access
|
|||
; pkg->assoc-table : FULL-PKG-SPEC path boolean? -> assoc-table
|
||||
; returns the on-disk packages for the given planet package in the
|
||||
; on-disk table rooted at the given directory
|
||||
(define (pkg->assoc-table pkg dir check-success?)
|
||||
(define (pkg->assoc-table pkg dir to-check)
|
||||
(define path (build-path (apply build-path dir (pkg-spec-path pkg)) (pkg-spec-name pkg)))
|
||||
|
||||
(define (tree-stuff->row-or-false p majs mins)
|
||||
|
|
@ -170,8 +169,18 @@ Various common pieces of code that both the client and server need to access
|
|||
(if (and (path? p) maj min)
|
||||
(let* ((the-path (build-path path majs mins))
|
||||
(min-core-version (get-min-core-version the-path)))
|
||||
(and (or (not check-success?)
|
||||
(installed-successfully? the-path))
|
||||
(and (cond
|
||||
[(eq? to-check 'success)
|
||||
(if (member the-path (held-locks))
|
||||
;; this means we're in the process of installing this package
|
||||
;; and the files should be already there in the filesystem
|
||||
;; so we count that as just having to check if they are unpacked
|
||||
|
||||
(file-exists? (dir->unpacked-file the-path))
|
||||
(file-exists? (dir->successful-installation-file the-path)))]
|
||||
[(eq? to-check 'unpacked)
|
||||
(file-exists? (dir->unpacked-file the-path))]
|
||||
[else #t])
|
||||
(make-assoc-table-row
|
||||
(pkg-spec-name pkg)
|
||||
(pkg-spec-path pkg)
|
||||
|
|
@ -751,12 +760,12 @@ Various common pieces of code that both the client and server need to access
|
|||
|
||||
|
||||
|
||||
;; check/take-installation-lock : path -> (or/c port #f)
|
||||
;; check/take-installation-lock : path (-> void) -> (or/c port #f)
|
||||
;; if this function returns #t, then it successfully
|
||||
;; optained the installation lock.
|
||||
;; if it returns #f, then we tried to grab the lock, but someone
|
||||
;; else already had it, so we waited until that installation finished
|
||||
(define (check/take-installation-lock dir)
|
||||
(define (check/take-installation-lock dir do-installation)
|
||||
(define lf (dir->lock-file dir))
|
||||
;; make sure the lock file exists
|
||||
(with-handlers ((exn:fail:filesystem:exists? void))
|
||||
|
|
@ -765,9 +774,13 @@ Various common pieces of code that both the client and server need to access
|
|||
(cond
|
||||
[(port-try-file-lock? p 'exclusive)
|
||||
;; we got the lock; keep the file open
|
||||
p]
|
||||
(parameterize ([held-locks (cons dir (held-locks))])
|
||||
(dynamic-wind
|
||||
(λ () (void))
|
||||
(λ () (do-installation))
|
||||
(λ () (close-output-port p))))]
|
||||
[else
|
||||
;; we didn't get the lock; poll for the SUCCESS FILE
|
||||
;; we didn't get the lock (and didn't alreayd have it); poll for the SUCCESS FILE
|
||||
(planet-log "waiting for someone else to finish installation in ~s" dir)
|
||||
(let loop ()
|
||||
(cond
|
||||
|
|
@ -778,25 +791,17 @@ Various common pieces of code that both the client and server need to access
|
|||
(sleep 2)
|
||||
(loop)]))]))
|
||||
|
||||
;; release-installation-lock : port -> void
|
||||
;; call this function when check/take-intallation-lock returns #t
|
||||
;; (and the installation has finished)
|
||||
;; SIDE-EFFECT: creates the SUCCESS file (before releasing the lock)
|
||||
(define (release-installation-lock port)
|
||||
(close-output-port port))
|
||||
(define held-locks (make-parameter '()))
|
||||
|
||||
(define (installed-successfully? dir)
|
||||
(file-exists? (dir->successful-installation-file dir)))
|
||||
(define (dir->successful-installation-file dir) (dir->something-file dir #".SUCCESS"))
|
||||
(define (dir->lock-file dir) (dir->something-file dir #".LOCK"))
|
||||
(define (dir->unpacked-file dir) (dir->something-file dir #".UNPACKED"))
|
||||
|
||||
(define (dir->successful-installation-file dir)
|
||||
(define (dir->something-file dir something)
|
||||
(define-values (base name dir?) (split-path dir))
|
||||
(build-path base (bytes->path (bytes-append (path->bytes name) #".SUCCESS"))))
|
||||
|
||||
(define (dir->lock-file dir)
|
||||
(define-values (base name dir?) (split-path dir))
|
||||
(build-path base (bytes->path (bytes-append (path->bytes name) #".LOCK"))))
|
||||
(build-path base (bytes->path (bytes-append (path->bytes name) something))))
|
||||
|
||||
(define (dir->metadata-files dir)
|
||||
(list (dir->lock-file dir)
|
||||
(dir->unpacked-file dir)
|
||||
(dir->successful-installation-file dir)))
|
||||
|
||||
|
|
@ -160,6 +160,10 @@ in its link-table for that require line. If one exists, it uses the named
|
|||
package directly. If none exists, it checks to see if there is an appropriate
|
||||
subdirectory.
|
||||
|
||||
4. File Locking Behavior
|
||||
|
||||
See the scribble documentation on the planet/resolver module.
|
||||
|
||||
||#
|
||||
|
||||
|
||||
|
|
@ -337,7 +341,7 @@ subdirectory.
|
|||
[current-eval (call-with-parameterization orig-paramz current-eval)]
|
||||
[use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)]
|
||||
[current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)])
|
||||
(let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)])
|
||||
(let-values ([(path pkg) (get-planet-module-path/pkg/internal spec rmp stx load?)])
|
||||
(when load? (add-pkg-to-diamond-registry! pkg stx))
|
||||
(do-require path (pkg-path pkg) rmp stx load?))))
|
||||
|
||||
|
|
@ -351,11 +355,14 @@ subdirectory.
|
|||
;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
|
||||
;; returns the matching package and the file path to the specific request
|
||||
(define (get-planet-module-path/pkg spec rmp stx)
|
||||
(request->pkg (spec->req spec stx) rmp stx))
|
||||
(get-planet-module-path/pkg/internal spec rmp stx #f))
|
||||
|
||||
(define (get-planet-module-path/pkg/internal spec rmp stx load?)
|
||||
(request->pkg (spec->req spec stx) rmp stx load?))
|
||||
|
||||
;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
|
||||
(define (request->pkg req rmp stx)
|
||||
(let* ([result (get-package rmp (request-full-pkg-spec req))])
|
||||
;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] boolean -> (values path PKG)
|
||||
(define (request->pkg req rmp stx load?)
|
||||
(let* ([result (get-package rmp (request-full-pkg-spec req) load?)])
|
||||
(cond [(string? result)
|
||||
(raise-syntax-error 'require result stx)]
|
||||
[(pkg? result)
|
||||
|
|
@ -377,11 +384,12 @@ subdirectory.
|
|||
;; eventually, and a function that gets to mess with the error message if the
|
||||
;; entire message eventually fails.
|
||||
|
||||
;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string)
|
||||
;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC boolean -> (PKG | string)
|
||||
;; gets the package specified by pspec requested by the module in the given
|
||||
;; module path, or returns a descriptive error message string if that's not
|
||||
;; possible
|
||||
(define (get-package rmp pspec)
|
||||
;; possible; the boolean indicates if this request is going to require the file,
|
||||
;; or if it is just for informational purposes only (to find the file say)
|
||||
(define (get-package rmp pspec load?)
|
||||
(let loop ([getters (*package-search-chain*)]
|
||||
[pre-install-updaters '()]
|
||||
[post-install-updaters '()]
|
||||
|
|
@ -401,6 +409,7 @@ subdirectory.
|
|||
((car getters)
|
||||
rmp
|
||||
pspec
|
||||
load?
|
||||
(λ (pkg)
|
||||
(when (uninstalled-pkg? pkg)
|
||||
(for-each (λ (u) (u pkg)) pre-install-updaters))
|
||||
|
|
@ -420,8 +429,8 @@ subdirectory.
|
|||
;; =============================================================================
|
||||
|
||||
;; get/installed-cache : pkg-getter
|
||||
(define (get/installed-cache _ pkg-spec success-k failure-k)
|
||||
(let ([p (lookup-package pkg-spec #:check-success? #t)])
|
||||
(define (get/installed-cache _ pkg-spec load? success-k failure-k)
|
||||
(let ([p (lookup-package pkg-spec #:to-check (if load? 'success 'unpacked))])
|
||||
(if p (success-k p) (failure-k void void (λ (x) x)))))
|
||||
|
||||
;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
|
||||
|
|
@ -431,13 +440,13 @@ subdirectory.
|
|||
;; get/uninstalled-cache-dummy : pkg-getter
|
||||
;; always fails, but records the package to the uninstalled package cache upon
|
||||
;; the success of some other getter later in the chain.
|
||||
(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k)
|
||||
(define (get/uninstalled-cache-dummy _ pkg-spec load? success-k failure-k)
|
||||
(failure-k save-to-uninstalled-pkg-cache! void (λ (x) x)))
|
||||
|
||||
;; get/uninstalled-cache : pkg-getter
|
||||
;; note: this does not yet work with minimum-required-version specifiers if you
|
||||
;; install a package and then use an older mzscheme
|
||||
(define (get/uninstalled-cache _ pkg-spec success-k failure-k)
|
||||
(define (get/uninstalled-cache _ pkg-spec load? success-k failure-k)
|
||||
(let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
|
||||
(if (and p (file-exists? (build-path (pkg-path p)
|
||||
(pkg-spec-name pkg-spec))))
|
||||
|
|
@ -491,7 +500,7 @@ subdirectory.
|
|||
;; locally.
|
||||
;; =============================================================================
|
||||
|
||||
(define (get/server _ pkg-spec success-k failure-k)
|
||||
(define (get/server _ pkg-spec load? success-k failure-k)
|
||||
(let ([p (get-package-from-server pkg-spec)])
|
||||
(cond
|
||||
[(pkg-promise? p) (success-k p)]
|
||||
|
|
@ -584,37 +593,48 @@ subdirectory.
|
|||
|
||||
(parameterize ([planet-nested-install #t])
|
||||
(planet-terse-log 'install pkg-string)
|
||||
(with-logging
|
||||
(LOG-FILE)
|
||||
(lambda ()
|
||||
|
||||
(define lock/f #f)
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(set! lock/f (check/take-installation-lock the-dir))
|
||||
(when lock/f
|
||||
(printf "\n============= Installing ~a on ~a =============\n"
|
||||
pkg-name
|
||||
(current-time))
|
||||
;; oh man is this a bad hack!
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(let ([ipp (dynamic-require 'setup/plt-single-installer
|
||||
'install-planet-package)]
|
||||
[rud (dynamic-require 'setup/plt-single-installer
|
||||
'reindex-user-documentation)]
|
||||
[msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)])
|
||||
(parameterize ([msfh (manager-skip-file-handler)]
|
||||
[use-compiled-file-paths (list (string->path "compiled"))])
|
||||
(ipp path the-dir (list owner pkg-name
|
||||
extra-path maj min))
|
||||
(unless was-nested?
|
||||
(planet-terse-log 'docs-build pkg-string)
|
||||
(printf "------------- Rebuilding documentation index -------------\n")
|
||||
(rud)))))
|
||||
(call-with-output-file (dir->successful-installation-file the-dir) void)))
|
||||
(λ () (when lock/f
|
||||
(release-installation-lock lock/f))))))
|
||||
(check/take-installation-lock
|
||||
the-dir
|
||||
(λ ()
|
||||
(with-logging
|
||||
(LOG-FILE)
|
||||
(lambda ()
|
||||
|
||||
|
||||
;; oh man is this a bad hack!
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(let ([up (dynamic-require 'setup/unpack 'unpack)]
|
||||
[fcd (dynamic-require 'setup/dirs 'find-collects-dir)]
|
||||
[ipp (dynamic-require 'setup/plt-single-installer
|
||||
'install-planet-package)]
|
||||
[rud (dynamic-require 'setup/plt-single-installer
|
||||
'reindex-user-documentation)]
|
||||
[msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)])
|
||||
|
||||
(printf "\n============= Unpacking ~a =============\n"
|
||||
pkg-name)
|
||||
(parameterize ([current-directory (or (fcd) (current-directory))])
|
||||
(up path
|
||||
(current-directory)
|
||||
(λ (x) (printf "~a\n" x))
|
||||
(λ () the-dir)))
|
||||
|
||||
;; signal that all of the files are now in place
|
||||
(call-with-output-file (dir->unpacked-file the-dir) void
|
||||
#:exists 'truncate)
|
||||
|
||||
(printf "\n============= Installing ~a on ~a =============\n"
|
||||
pkg-name
|
||||
(current-time))
|
||||
(parameterize ([msfh (manager-skip-file-handler)]
|
||||
[use-compiled-file-paths (list (string->path "compiled"))])
|
||||
(ipp #f the-dir (list owner pkg-name
|
||||
extra-path maj min))
|
||||
(unless was-nested?
|
||||
(planet-terse-log 'docs-build pkg-string)
|
||||
(printf "\n============= Rebuilding documentation index =============\n")
|
||||
(rud)))))
|
||||
(call-with-output-file (dir->successful-installation-file the-dir) void)))))
|
||||
(planet-terse-log 'finish pkg-string)
|
||||
(make-pkg pkg-name pkg-path
|
||||
maj min the-dir 'normal)))
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
@title{Utility Libraries}
|
||||
|
||||
The planet collection provides configuration and utilities for using PLaneT.
|
||||
The planet collection provides configuration and utilities for using @|PLaneT|.
|
||||
|
||||
@section{Resolver}
|
||||
|
||||
|
|
@ -32,7 +32,7 @@ the resolvers behavior.
|
|||
[orig-paramz parameterization?])
|
||||
resolved-module-path?))]{
|
||||
This implements the @|PLaneT| module resolution process. It is @racket[dynamic-require]d
|
||||
by racket when the first planet module require is needed. It acts much like a
|
||||
by racket when the first @|PLaneT| module require is needed. It acts much like a
|
||||
@racket[current-module-name-resolver] would, but racket provides it with a special
|
||||
@racket[parameterization?] (giving it special privileges) that it uses when installing new packages.
|
||||
}
|
||||
|
|
@ -41,7 +41,7 @@ the resolvers behavior.
|
|||
[module-path (or/c #f resolved-module-path?)]
|
||||
[stx (or/c #f syntax?)])
|
||||
(values path? pkg?)]{
|
||||
Returns the path corresponding to the planet package (interpreting the arguments
|
||||
Returns the path corresponding to the package (interpreting the arguments
|
||||
the same way as @racket[planet-module-name-resolver] and @racket[(current-module-name-resolver)]).
|
||||
}
|
||||
|
||||
|
|
@ -50,17 +50,70 @@ the resolvers behavior.
|
|||
}
|
||||
|
||||
@defparam[download? dl? boolean?]{
|
||||
A parameter that controls if @PLaneT attempts to download a planet package that isn't already present.
|
||||
A parameter that controls if @PLaneT attempts to download a package that isn't already present.
|
||||
If the package isn't present, the resolver will raise the @racket[exn:fail:planet?] exception
|
||||
instead of downloading it.
|
||||
}
|
||||
|
||||
@defparam[install? inst? boolean?]{
|
||||
A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed.
|
||||
A parameter that controls if @PLaneT attempts to install a package that isn't already installed.
|
||||
If the package isn't installed, the resolver will raise the @racket[exn:fail:planet?] exception
|
||||
instead of installing it.
|
||||
}
|
||||
|
||||
@subsection{Resolver file locking}
|
||||
|
||||
When @|PLaneT| is asked to resolve a module path for loading the file
|
||||
(e.g., when the last argument to the @racket[(current-module-name-resolver)]
|
||||
is @racket[#t] and that resolver triggers a call to the @|PLaneT| resolver),
|
||||
it finds the directory
|
||||
where the files are installed, say in this directory, which
|
||||
corresponds to version 1.2 of dyoo's closure-compile.plt package:
|
||||
|
||||
@centered{@filepath{@racket[(CACHE-DIR)]/dyoo/closure-compile.plt/1/2/}}
|
||||
|
||||
If the file
|
||||
|
||||
@centered{@filepath{@racket[(CACHE-DIR)]/dyoo/closure-compile.plt/1/2.SUCCESS}}
|
||||
|
||||
is there, it assumes that there is no installation needed and it just
|
||||
continues, using the path to the file inside that directory.
|
||||
|
||||
If the @filepath{2.SUCCESS} file is not there, then it attempts to grab an
|
||||
@racket['exclusive] filesystem lock on this file (via @racket[port-try-file-lock?])
|
||||
|
||||
@centered{@filepath{@racket[(CACHE-DIR)]/dyoo/closure-compile.plt/1/2.LOCK}}
|
||||
|
||||
If it gets the lock, it then proceeds with the installation, calling
|
||||
raco setup to do the unpacking, compilation, and docs building.
|
||||
After the unpacking has finished, but before beginning compilation and docs
|
||||
building, it creates the @filepath{2.UNPACKED} file:
|
||||
|
||||
@centered{@filepath{@racket[(CACHE-DIR)]/dyoo/closure-compile.plt/1/2.UNPACKED}}
|
||||
|
||||
When compilation and docs build are complete, it creates the @filepath{2.SUCCESS} file:
|
||||
|
||||
@centered{@filepath{@racket[(CACHE-DIR)]/dyoo/closure-compile.plt/1/2.SUCCESS}}
|
||||
|
||||
and releases the lock on the @filepath{2.LOCK} file.
|
||||
|
||||
If it fails to get the lock on @filepath{2.LOCK} and it does not already hold the
|
||||
lock (due to a re-entrant call to the resolver (the resolver knows about locks it
|
||||
holds via an internal parameter that gets created when the @racketmodname[planet/resolver]
|
||||
module is instantiated) then it goes into a loop that polls for
|
||||
the existence of the @filepath{2.SUCCESS} file; when it that file appears, it
|
||||
just continues, without installing anything (since that means someone
|
||||
else installed it).
|
||||
|
||||
In some situations (e.g., when a new namespace is created and a fresh instantiation of
|
||||
@racketmodname[planet/resolver] is created), @|PLaneT| can be fooled into thinking that it
|
||||
does not hold the lock on some installation. In order to cope with these situations somewhat,
|
||||
@|PLaneT| takes an easier path when the resolver is only looking for information about
|
||||
package files (i.e., when the last argument to the resolver is @racket[#f], or when
|
||||
@racket[get-planet-module-path/pkg] is called directly (as opposed to being called
|
||||
via module resolution). In those cases, @|PLaneT| will look only for the
|
||||
@filepath{2.UNPACKED} file instead of the @filepath{2.SUCCESS} file.
|
||||
|
||||
@section{Client Configuration}
|
||||
|
||||
@defmodule[planet/config]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user