From 5455a16f47eecaf5984a9bdf76121931302cef60 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 19 Aug 2011 08:00:55 -0500 Subject: [PATCH] fix bugs in the file locking protocol for planet packages (in particular, support re-entrancy) --- collects/planet/private/linkage.rkt | 2 +- collects/planet/private/planet-shared.rkt | 61 ++++++------ collects/planet/private/resolver.rkt | 108 +++++++++++++--------- collects/planet/private/util.scrbl | 63 ++++++++++++- 4 files changed, 156 insertions(+), 78 deletions(-) diff --git a/collects/planet/private/linkage.rkt b/collects/planet/private/linkage.rkt index 6067ef7560..1d0b179991 100644 --- a/collects/planet/private/linkage.rkt +++ b/collects/planet/private/linkage.rkt @@ -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) diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index c705c50f2b..b68161b3eb 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -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))) - \ No newline at end of file diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index 3f1d0a5186..959be344f1 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -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))) diff --git a/collects/planet/private/util.scrbl b/collects/planet/private/util.scrbl index 529cb34e5a..19a3448c39 100644 --- a/collects/planet/private/util.scrbl +++ b/collects/planet/private/util.scrbl @@ -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]