change locking of preferences files under Windows
to avoid the problem that `rename-file-or-directory' cannot replace a file that is currently open for reading (unlike Unix)
This commit is contained in:
Matthew Flatt
parent
5998ecc564
commit
3e2af2f39e
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user