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)

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
+      (let-values ([(pref-file use-lock?)
-              (or filename
+                    (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.
-                        f
+                              (values f use-lock?)
                               ;; Look for old PLT Scheme pref file:
-                        (let ([alt-f (case (system-type)
+                              (let ([alt-f 
+                                     (case (system-type)
                                        [(windows)
                                         (build-path (find-system-path 'pref-dir)
                                                     'up "PLT Scheme" "plt-prefs.ss")]
@@ -161,22 +237,33 @@
                                        [(unix)
                                         (expand-user-path "~/.plt-scheme/plt-prefs.ss")])])
                                 (if (file-exists? alt-f)
-                              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"))))))]
+                                                           "defaults")
-             [prefs (with-pref-params
+                                     #f))))))])
+        (let ([prefs (with-pref-params
                       (lambda ()
-                       (with-input-from-file pref-file read)))])
+                        (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))))
+              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/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)))))
+           (if m (cadr m) (fail-thunk))))))))
 
 (define (put-preferences names vals [lock-there #f] [filename #f])
   (unless (and (list? names) (andmap symbol? names))
@@ -226,28 +345,14 @@
                         (make-directory* dir))
                       (values
                        filename
-                       (build-path dir
+                       (make-lock-file-name dir name)
-                                   (bytes->path-element
-                                    (bytes-append
-                                     (if (eq? 'windows (system-type))
-                                         #"_"
-                                         #".")
-                                     #"LOCK"
-                                     (path-element->bytes name))))
                        dir))))])
-    (with-handlers ([exn:fail:filesystem:exists?
+    (call-with-file-lock
-                     (lambda (x)
+     'put-preferences
-                       (if lock-there
+     'exclusive
-                           (lock-there lock-file)
+     (lambda () 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)])
+       (let ([f (get-prefs #t filename #f #f)])
          (set! f (let loop ([f f][a null])
                    (cond
                     [(null? f) (reverse
@@ -299,9 +404,7 @@
                                   tmp-file
                                   f)
              (rename-file-or-directory tmp-file pref-file #t)))))
-          (lambda ()
+     lock-there)))
-            ;; Release lock:
-            (delete-file lock-file))))))
 
 ;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
 (define (fold-files f init [path #f] [follow-links? #t])

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.}