diff --git a/collects/racket/file.rkt b/collects/racket/file.rkt index 7af13d62e1..dc3c350c38 100644 --- a/collects/racket/file.rkt +++ b/collects/racket/file.rkt @@ -7,6 +7,8 @@ get-preference put-preferences + preferences-lock-file-mode + make-handle-get-preference-locked fold-files find-files @@ -139,19 +141,93 @@ (unless (eq? table (weak-box-value pref-cache)) (set! pref-cache (make-weak-box table))))) -(define (get-prefs flush-mode filename) + +(define make-lock-file-name + (case-lambda + [(path) (let-values ([(dir name dir?) (split-path path)]) + (make-lock-file-name dir name))] + [(dir name) + (build-path dir + (bytes->path-element + (bytes-append + (if (eq? 'windows (system-type)) + #"_" + #".") + #"LOCK" + (path-element->bytes name))))])) + +(define (preferences-lock-file-mode) + (case (system-type) + [(windows) 'file-lock] + [else 'exists])) + +(define (call-with-file-lock who kind get-lock-file thunk lock-there) + (case (preferences-lock-file-mode) + [(file-lock) + (let ([lock-file (get-lock-file)]) + ;; Create the lock file if it doesn't exist: + (unless (file-exists? lock-file) + (with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)]) + (close-output-port (open-output-file lock-file #:exists 'error)))) + ((call-with-input-file* + lock-file + (lambda (p) + (if (port-try-file-lock? p kind) + ;; got lock: + (let ([v (dynamic-wind + void + thunk + (lambda () + (port-file-unlock p)))]) + (lambda () v)) + ;; didn't get lock: + (if lock-there + (lambda () (lock-there lock-file)) + (error who + "~a ~a: ~e" + "some other process has a lock" + "on the preferences lock file" + lock-file)))))))] + [else ; = 'exists + ;; Only a write lock is needed, and the file lock + ;; is implemented by the presence of the file: + (case kind + [(shared) (thunk)] + [(exclusive) + (let ([lock-file (get-lock-file)]) + (with-handlers ([exn:fail:filesystem:exists? + (lambda (x) + (if lock-there + (lock-there lock-file) + (error who + "~a, ~a: ~e" + "some other process has the preference-file lock" + "as indicated by the existence of the lock file" + lock-file)))]) + ;; Grab lock: + (close-output-port (open-output-file lock-file #:exists 'error))) + (dynamic-wind + void + thunk + (lambda () + ;; Release lock: + (delete-file lock-file))))])])) + +(define (get-prefs flush-mode filename use-lock? lock-there) (define (read-prefs default-pref-file) (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (let* ([pref-file - (or filename - (let ([f default-pref-file]) - (if (file-exists? f) - ;; Using `file-exists?' means there's technically a - ;; race condition, but something has gone really wrong - ;; if the file disappears. - f - ;; Look for old PLT Scheme pref file: - (let ([alt-f (case (system-type) + (let-values ([(pref-file use-lock?) + (if filename + (values filename use-lock?) + (let ([f default-pref-file]) + (if (file-exists? f) + ;; Using `file-exists?' means there's technically a + ;; race condition, but something has gone really wrong + ;; if the file disappears. + (values f use-lock?) + ;; Look for old PLT Scheme pref file: + (let ([alt-f + (case (system-type) [(windows) (build-path (find-system-path 'pref-dir) 'up "PLT Scheme" "plt-prefs.ss")] @@ -160,23 +236,34 @@ "org.plt-scheme.prefs.ss")] [(unix) (expand-user-path "~/.plt-scheme/plt-prefs.ss")])]) - (if (file-exists? alt-f) - alt-f - ;; Last chance: check for a "defaults" collection: - ;; (error here in case there's no "defaults" - ;; bails out through above `with-handlers') - (collection-file-path "racket-prefs.rktd" - "defaults"))))))] - [prefs (with-pref-params - (lambda () - (with-input-from-file pref-file read)))]) - ;; Make sure file content had the right shape: - (if (and (list? prefs) - (andmap (lambda (x) - (and (pair? x) (pair? (cdr x)) (null? (cddr x)))) - prefs)) - prefs - null)))) + (if (file-exists? alt-f) + (values alt-f #f) + ;; Last chance: check for a "defaults" collection: + ;; (error here in case there's no "defaults" + ;; bails out through above `with-handlers') + (values + (collection-file-path "racket-prefs.rktd" + "defaults") + #f))))))]) + (let ([prefs (with-pref-params + (lambda () + (if use-lock? + (call-with-file-lock + 'get-preferences + 'shared + (lambda () + (make-lock-file-name pref-file)) + (lambda () + (with-input-from-file pref-file read)) + lock-there) + (with-input-from-file pref-file read))))]) + ;; Make sure file content had the right shape: + (if (and (list? prefs) + (andmap (lambda (x) + (and (pair? x) (pair? (cdr x)) (null? (cddr x)))) + prefs)) + prefs + null))))) (let* ([fn (path->complete-path (or filename (find-system-path 'pref-file)))] @@ -193,17 +280,49 @@ (pref-cache-install! fn fn f) f)))) +(define (make-handle-get-preference-locked delay + name + [fail-thunk (lambda () #f)] + [refresh-cache? 'timestamp] + [filename #f] + #:lock-there [lock-there #f] + #:max-delay [max-delay 0.2]) + (lambda (lock-filename) + (sleep delay) + (get-preference name fail-thunk refresh-cache? filename + #:lock-there (let ([new-delay (* 2 delay)]) + (if (new-delay . < . max-delay) + (make-handle-get-preference-locked + new-delay + name fail-thunk refresh-cache? filename + #:lock-there lock-there + #:max-delay max-delay) + lock-there))))) + (define (get-preference name [fail-thunk (lambda () #f)] [refresh-cache? 'timestamp] - [filename #f]) + [filename #f] + #:lock-there [lock-there + (make-handle-get-preference-locked + 0.01 + name + fail-thunk + refresh-cache? + filename)] + #:use-lock? [use-lock? #t]) (unless (symbol? name) (raise-type-error 'get-preference "symbol" name)) (unless (and (procedure? fail-thunk) (procedure-arity-includes? fail-thunk 0)) (raise-type-error 'get-preference "procedure (arity 0)" fail-thunk)) - (let ([f (get-prefs refresh-cache? filename)]) - (let ([m (assq name f)]) - (if m (cadr m) (fail-thunk))))) + ((let/ec esc + (let ([f (get-prefs refresh-cache? filename use-lock? + (and lock-there + (lambda (file) + (esc (lambda () (lock-there file))))))]) + (lambda () + (let ([m (assq name f)]) + (if m (cadr m) (fail-thunk)))))))) (define (put-preferences names vals [lock-there #f] [filename #f]) (unless (and (list? names) (andmap symbol? names)) @@ -226,82 +345,66 @@ (make-directory* dir)) (values filename - (build-path dir - (bytes->path-element - (bytes-append - (if (eq? 'windows (system-type)) - #"_" - #".") - #"LOCK" - (path-element->bytes name)))) + (make-lock-file-name dir name) dir))))]) - (with-handlers ([exn:fail:filesystem:exists? - (lambda (x) - (if lock-there - (lock-there lock-file) - (error 'put-preferences - "some other process has the preference-file lock, as indicated by the existence of the lock file: ~e" - lock-file)))]) - ;; Grab lock: - (close-output-port (open-output-file lock-file #:exists 'error)) - (dynamic-wind - void - (lambda () - (let ([f (get-prefs #t filename)]) - (set! f (let loop ([f f][a null]) - (cond - [(null? f) (reverse - (append (map list names vals) - a))] - [else (if (memq (caar f) names) - (loop (cdr f) a) - (loop (cdr f) (cons (car f) a)))]))) - ;; To write the file, copy the old one to a temporary name - ;; (preserves permissions, etc), write to the temp file, - ;; then move (atomicly) the temp file to the normal name. - (let ([tmp-file (make-temporary-file - "TMPPREF~a" - (and (file-exists? pref-file) pref-file) - pref-dir)]) - ;; If something goes wrong, try to delete the temp file. - (with-handlers ([exn:fail? (lambda (exn) - (with-handlers ([exn:fail:filesystem? void]) - (delete-file tmp-file)) - (raise exn))]) - ;; Write to temp file... - (with-output-to-file tmp-file - #:exists 'truncate/replace - (lambda () - (with-pref-params - (lambda () - ;; If a pref value turns out to be unreadable, raise - ;; an exception instead of creating a bad pref file. - (parameterize ([print-unreadable #f]) - ;; Poor man's pretty-print: one line per entry. - (printf "(\n") - (for-each (lambda (a) - (if (and (list? (cadr a)) - (< 4 (length (cadr a)))) - (begin - (printf " (~s\n (\n" (car a)) - (for-each (lambda (i) (printf " ~s\n" i)) (cadr a)) - (printf " ))\n")) - (printf " ~s\n" a))) - f) - (printf ")\n")))))) - ;; Install the new table in the cache. It's possible that this - ;; cache entry will be replaced by a reading thread before we - ;; move the file, but that's ok. It just means that a future - ;; reading thread will have to read again. - (pref-cache-install! (path->complete-path - (or filename - (find-system-path 'pref-file))) - tmp-file - f) - (rename-file-or-directory tmp-file pref-file #t))))) - (lambda () - ;; Release lock: - (delete-file lock-file)))))) + (call-with-file-lock + 'put-preferences + 'exclusive + (lambda () lock-file) + (lambda () + (let ([f (get-prefs #t filename #f #f)]) + (set! f (let loop ([f f][a null]) + (cond + [(null? f) (reverse + (append (map list names vals) + a))] + [else (if (memq (caar f) names) + (loop (cdr f) a) + (loop (cdr f) (cons (car f) a)))]))) + ;; To write the file, copy the old one to a temporary name + ;; (preserves permissions, etc), write to the temp file, + ;; then move (atomicly) the temp file to the normal name. + (let ([tmp-file (make-temporary-file + "TMPPREF~a" + (and (file-exists? pref-file) pref-file) + pref-dir)]) + ;; If something goes wrong, try to delete the temp file. + (with-handlers ([exn:fail? (lambda (exn) + (with-handlers ([exn:fail:filesystem? void]) + (delete-file tmp-file)) + (raise exn))]) + ;; Write to temp file... + (with-output-to-file tmp-file + #:exists 'truncate/replace + (lambda () + (with-pref-params + (lambda () + ;; If a pref value turns out to be unreadable, raise + ;; an exception instead of creating a bad pref file. + (parameterize ([print-unreadable #f]) + ;; Poor man's pretty-print: one line per entry. + (printf "(\n") + (for-each (lambda (a) + (if (and (list? (cadr a)) + (< 4 (length (cadr a)))) + (begin + (printf " (~s\n (\n" (car a)) + (for-each (lambda (i) (printf " ~s\n" i)) (cadr a)) + (printf " ))\n")) + (printf " ~s\n" a))) + f) + (printf ")\n")))))) + ;; Install the new table in the cache. It's possible that this + ;; cache entry will be replaced by a reading thread before we + ;; move the file, but that's ok. It just means that a future + ;; reading thread will have to read again. + (pref-cache-install! (path->complete-path + (or filename + (find-system-path 'pref-file))) + tmp-file + f) + (rename-file-or-directory tmp-file pref-file #t))))) + lock-there))) ;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha (define (fold-files f init [path #f] [follow-links? #t]) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index d1b7af9472..8992e642a5 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -853,10 +853,20 @@ desired access and flags (probably using the @racket['truncate] flag; see @racket[open-output-file]) and to delete it when it is no longer needed.} + @defproc[(get-preference [name symbol?] [failure-thunk (-> any) (lambda () #f)] [flush-mode any/c 'timestamp] - [filename (or/c string-path? #f) #f]) + [filename (or/c string-path? #f) #f] + [#:lock-there + lock-there + (or/c (path? . -> . any) #f) + (make-handle-get-preference-locked 0.01 + name + fail-thunk + refresh-cache? + filename)] + [#:use-lock? use-lock? #t]) any]{ Extracts a preference value from the file designated by @@ -887,6 +897,16 @@ then the cache is used only if the file has a timestamp that is the same as the last time the file was read. Otherwise, the file is re-consulted. +Under platforms for which @racket[preferences-lock-file-mode] returns +@racket['file-lock] and when @racket[use-lock?] is true, +preference-file reading is guarded by a lock; multiple readers can +share the lock, but writers take the lock exclusively. If the +preferences file cannot be read because the lock is unavailable, +@racket[lock-there] is called on the path of the lock file; if +@racket[lock-there] is @racket[#f], an exception is raised. The +default @racket[lock-there] handler retries about 5 times (with +increasing delays between each attempt) before raising an exception. + See also @racket[put-preferences]. For a more elaborate preference system, see @racket[preferences:get]. @@ -924,21 +944,66 @@ whose @racket[write] output is @racket[read]able (i.e., the writing preferences). Current preference values are read from the preference file before -updating, and an update ``lock'' is held starting before the file +updating, and a write lock is held starting before the file read, and lasting until after the preferences file is updated. The lock is implemented by the existence of a file in the same directory -as the preference file. If the directory of the preferences file does +as the preference file; see @racket[preferences-lock-file-mode] for +more information. If the directory of the preferences file does not already exist, it is created. -If the update lock is already held (i.e., the lock file exists), then +If the write lock is already held, then @racket[locked-proc] is called with a single argument: the path of the lock file. The default @racket[locked-proc] reports an error; an alternative thunk might wait a while and try again, or give the user the choice to delete the lock file (in case a previous update attempt encountered -disaster). +disaster and locks are implemented by the presence of the lock file). If @racket[filename] is @racket[#f] or not supplied, and the preference file does not already exist, then values read from the @filepath{defaults} collection (if any) are written for preferences that are not mentioned in @racket[names].} + +@defproc[(preferences-lock-file-mode) (or/c 'exists 'file-lock)]{ + +Reports the way that the lock file is used to implement +preference-file locking on the current platform. + +The @racket['exists] mode is currently used on all platforms except +Windows. In @racket['exists] mode, the existence of the lock file +indicates that a write lock is held, and readers need no lock (because +the preferences file is atomically updated via +@racket[rename-file-or-directory]). + +The @racket['file-lock] mode is currently used under Windows. In +@racket['file-lock] mode, shared and exclusive locks (in the sense of +@racket[port-try-file-lock?]) on the lock file reflect reader and +writer locks on the preference-file content. (The preference file +itself is not locked, because a lock would interfere with replacing +the file via @racket[rename-file-or-directory].)} + + +@defproc[(make-handle-get-preference-locked + [delay real?] + [name symbol?] + [failure-thunk (-> any) (lambda () #f)] + [flush-mode any/c 'timestamp] + [filename (or/c string-path? #f) #f] + [#:lock-there lock-there (or/c (path? . -> . any) #f) #f] + [#:max-delay max-delay real? 0.2]) + (path-string? . -> . any)]{ + +Creates a procedure suitable for use as the @racket[#:lock-there] +argument to @racket[get-preference], where the @racket[name], +@racket[failure-thunk], @racket[flush-mode], and @racket[filename] +are all passed on to @racket[get-preference] by the result procedure +to retry the preferences lookup. + +Before calling @racket[get-preference], the result procedure uses +@racket[(sleep delay)] to pause. Then, if @racket[(* 2 delay)] is less +than @racket[max-delay], the result procedure calls +@racket[make-handle-get-preference-locked] to generate a new retry +procedure to pass to @racket[get-preference], but with a +@racket[delay] of @racket[(* 2 delay)]. If @racket[(* 2 delay)] is not +less than @racket[max-delay], then @racket[get-preference] is called +with the given @racket[lock-there], instead.}