Add locking mechanism for the IMAP folder cache. There is one lock

per folder, and the lock is held only while the folder cache is being
read and/or written.  IMAIL will try three times to obtain the lock,
waiting one second between retries; thereafter it ignores the cache
until the lock becomes available.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 7cb8c972cd54a1c04f2c4a3a669821989f45981a..645e5e108313fbe78ea4b49cca8901e92d817f83 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.190 2001/10/14 02:00:13 cph Exp $
+;;; $Id: imail-imap.scm,v 1.191 2001/11/06 04:44:38 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -1140,10 +1140,14 @@
 (define-method preload-folder-outlines ((folder <imap-folder>))
   (for-each-message folder
     (lambda (message)
-      (if (not (imap-message-header-fields-initialized? message))
-         (preload-cached-message-item message 'RFC822.HEADER))
-      (if (not (imap-message-length-initialized? message))
-         (preload-cached-message-item message 'RFC822.SIZE))))
+      (with-folder-locked (message-folder message)
+       (lambda ()
+         (if (not (imap-message-header-fields-initialized? message))
+             (preload-cached-message-item message 'RFC822.HEADER))
+         (if (not (imap-message-length-initialized? message))
+             (preload-cached-message-item message 'RFC822.SIZE)))
+       (lambda ()
+         unspecific))))
   (let* ((connection (guarantee-imap-folder-open folder))
         (messages
          (messages-satisfying folder
@@ -1431,19 +1435,23 @@
   (let ((directory (imap-folder-cache-pathname folder))
        (uidvalidity (imap-folder-uidvalidity folder)))
     (if uidvalidity
-       (let ((up (merge-pathnames "uidvalidity" directory)))
-         (if (file-directory? directory)
-             (let ((uidvalidity* (simple-read-file up)))
-               (if (and (file-regular? up)
-                        (eqv? uidvalidity* uidvalidity))
-                   (remove-expunged-messages folder directory)
-                   (begin
-                     (delete-directory-contents directory)
-                     (simple-write-file uidvalidity up))))
-             (begin
-               (delete-file-no-errors directory)
-               (guarantee-init-file-directory directory)
-               (simple-write-file uidvalidity up)))))))
+       (with-folder-locked folder
+         (lambda ()
+           (let ((up (merge-pathnames "uidvalidity" directory)))
+             (if (file-directory? directory)
+                 (let ((uidvalidity* (simple-read-file up)))
+                   (if (and (file-regular? up)
+                            (eqv? uidvalidity* uidvalidity))
+                       (remove-expunged-messages folder directory)
+                       (begin
+                         (delete-directory-contents directory)
+                         (simple-write-file uidvalidity up))))
+                 (begin
+                   (delete-file-no-errors directory)
+                   (guarantee-init-file-directory directory)
+                   (simple-write-file uidvalidity up)))))
+         (lambda ()
+           unspecific)))))
 
 (define (remove-expunged-messages folder directory)
   (for-each (lambda (pathname)
@@ -1472,33 +1480,37 @@
 (define (fetch-message-items message keywords suffix)
   (if (equal? keywords '(FLAGS))
       (fetch-message-items-1 message keywords suffix)
-      (let ((alist
-            (map (lambda (keyword)
-                   (cons keyword
-                         (let ((pathname
-                                (message-item-pathname message keyword)))
-                           (if (file-exists? pathname)
-                               (list
-                                (read-cached-message-item message
-                                                          keyword
-                                                          pathname))
-                               '()))))
-                 keywords)))
-       (let ((uncached
-              (list-transform-positive alist
-                (lambda (entry)
-                  (null? (cdr entry))))))
-         (if (pair? uncached)
-             (let ((response
-                    (fetch-message-items-1 message
-                                           (map car uncached)
-                                           suffix)))
-               (cache-fetch-response message response
-                 (lambda (keyword)
-                   (assq keyword alist))
-                 (lambda (keyword item)
-                   (set-cdr! (assq keyword alist) (list item)))))))
-       `(FETCH ,(+ (message-index message) 1) ,@alist))))
+      (with-folder-locked (message-folder message)
+       (lambda ()
+         (let ((alist
+                (map (lambda (keyword)
+                       (cons keyword
+                             (let ((pathname
+                                    (message-item-pathname message keyword)))
+                               (if (file-exists? pathname)
+                                   (list
+                                    (read-cached-message-item message
+                                                              keyword
+                                                              pathname))
+                                   '()))))
+                     keywords)))
+           (let ((uncached
+                  (list-transform-positive alist
+                    (lambda (entry)
+                      (null? (cdr entry))))))
+             (if (pair? uncached)
+                 (let ((response
+                        (fetch-message-items-1 message
+                                               (map car uncached)
+                                               suffix)))
+                   (cache-fetch-response message response
+                     (lambda (keyword)
+                       (assq keyword alist))
+                     (lambda (keyword item)
+                       (set-cdr! (assq keyword alist) (list item)))))))
+           `(FETCH ,(+ (message-index message) 1) ,@alist)))
+       (lambda ()
+         (fetch-message-items-1 message keywords suffix)))))
 
 (define (cache-fetch-response message response keyword-predicate save-item)
   (for-each (lambda (keyword)
@@ -1528,26 +1540,35 @@
 \f
 (define (fetch-message-body-part-to-port message section port)
   (let ((keyword (imap-body-section->keyword section)))
-    (let ((pathname (message-item-pathname message keyword)))
-      (if (not (file-exists? pathname))
-         (begin
-           (guarantee-init-file-directory pathname)
-           (call-with-output-file pathname
-             (lambda (port)
-               (imap:bind-fetch-body-part-port port
-                 (lambda ()
-                   (fetch-message-body-part-1 message section keyword)))))))
-      (file->port pathname port))))
+    (let ((fetch-to-port
+          (lambda (port)
+            (imap:bind-fetch-body-part-port port
+              (lambda ()
+                (fetch-message-body-part-1 message section keyword))))))
+      (with-folder-locked (message-folder message)
+       (lambda ()
+         (let ((pathname (message-item-pathname message keyword)))
+           (if (not (file-exists? pathname))
+               (begin
+                 (guarantee-init-file-directory pathname)
+                 (call-with-output-file pathname fetch-to-port)))
+           (file->port pathname port)))
+       (lambda ()
+         (fetch-to-port port))))))
 
 (define (fetch-message-body-part message section)
   (let ((keyword (imap-body-section->keyword section)))
-    (let ((pathname (message-item-pathname message keyword)))
-      (if (file-exists? pathname)
-         (file->string pathname)
-         (let ((part (fetch-message-body-part-1 message section keyword)))
-           (guarantee-init-file-directory pathname)
-           (string->file part pathname)
-           part)))))
+    (with-folder-locked (message-folder message)
+      (lambda ()
+       (let ((pathname (message-item-pathname message keyword)))
+         (if (file-exists? pathname)
+             (file->string pathname)
+             (let ((part (fetch-message-body-part-1 message section keyword)))
+               (guarantee-init-file-directory pathname)
+               (string->file part pathname)
+               part))))
+      (lambda ()
+       (fetch-message-body-part-1 message section keyword)))))
 
 (define (fetch-message-body-part-1 message section keyword)
   (imap:response:fetch-body-part
@@ -1578,24 +1599,64 @@
                             (symbol-name x)))
                       section))
                 "]"))
-
+\f
 (define (preload-cached-message-item message keyword)
   (let ((pathname (message-item-pathname message keyword)))
     (if (file-exists? pathname)
        (read-cached-message-item message keyword pathname))))
 
 (define (cache-preload-responses folder keywords responses)
-  (for-each
-   (lambda (response)
-     (cache-fetch-response
-      (%get-message folder (- (imap:response:fetch-index response) 1))
-      response
-      (lambda (keyword) (memq keyword keywords))
-      (lambda (keyword item) keyword item unspecific)))
-   responses))
+  (for-each (lambda (response)
+             (let ((message
+                    (%get-message folder
+                                  (- (imap:response:fetch-index response)
+                                     1))))
+               (with-folder-locked (message-folder message)
+                 (lambda ()
+                   (cache-fetch-response message response
+                     (lambda (keyword) (memq keyword keywords))
+                     (lambda (keyword item) keyword item unspecific)))
+                 (lambda ()
+                   unspecific))))
+           responses))
 
 (define (delete-cached-message message)
-  (delete-file-recursively (imap-message-cache-pathname message)))
+  (with-folder-locked (message-folder message)
+    (lambda ()
+      (delete-file-recursively (imap-message-cache-pathname message)))))
+
+(define (with-folder-locked folder if-locked if-not-locked)
+  (let ((pathname (imap-folder-lock-pathname folder))
+       (locked? #f))
+    (dynamic-wind
+     (lambda () unspecific)
+     (lambda ()
+       (let loop ((i 0))
+        (without-interrupts
+         (lambda ()
+           (set! locked? (allocate-temporary-file pathname))
+           unspecific))
+        (cond (locked?
+               (if (> i 0)
+                   (imail-ui:clear-message))
+               (remove-property! folder 'IMAP-CACHE-LOCK-FAILURE)
+               (if-locked))
+              ((get-property folder 'IMAP-CACHE-LOCK-FAILURE #f)
+               (if-not-locked))
+              ((= i 2)
+               (imail-ui:clear-message)
+               (store-property! folder 'IMAP-CACHE-LOCK-FAILURE #t)
+               (if-not-locked))
+              (else
+               (imail-ui:message "Waiting for folder lock..." i)
+               (imail-ui:sit-for 1000)
+               (loop (+ i 1))))))
+     (lambda ()
+       (if locked?
+          (deallocate-temporary-file pathname))))))
+
+(define (clear-lock-state-on-folder-close folder)
+  (remove-property! folder 'IMAP-CACHE-LOCK-FAILURE))
 \f
 (define (message-item-pathname message keyword)
   (init-file-specifier->pathname
@@ -1610,6 +1671,12 @@
   `(,@(imap-folder-cache-specifier (message-folder message))
     ,(write-to-string (imap-message-uid message))))
 
+(define (imap-folder-lock-pathname folder)
+  (let ((spec (imap-folder-cache-specifier folder)))
+    (let ((p (last-pair spec)))
+      (set-car! p (string-append (car p) "#lock")))
+    (init-file-specifier->pathname spec)))
+
 (define (imap-folder-cache-pathname folder)
   (pathname-as-directory
    (init-file-specifier->pathname (imap-folder-cache-specifier folder))))
@@ -1794,6 +1861,7 @@
     (if connection
        (begin
          (maybe-close-imap-connection connection 0 no-defer?)
+         (clear-lock-state-on-folder-close folder)
          (object-modified! folder 'STATUS)))))
 
 (define-method %get-message ((folder <imap-folder>) index)

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index f85833fd608cfbdacbbf5976def5615b880982e6..fd5caca83bef9f570552cfee6f69843a14bfaf19 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.277 2001/10/30 19:29:11 cph Exp $
+;;; $Id: imail-top.scm,v 1.278 2001/11/06 04:45:13 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -1875,6 +1875,8 @@ Negative argument means search in reverse."
 (define *imail-message-wrapper-prefix* #f)
 
 (define imail-ui:message message)
+(define imail-ui:clear-message clear-message)
+(define imail-ui:sit-for sit-for)
 (define imail-ui:prompt-for-alist-value prompt-for-alist-value)
 (define imail-ui:prompt-for-yes-or-no? prompt-for-yes-or-no?)
 

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 4ca1c076089d78b41c70c3228166820d33b96c18..957090f928a8d854ad7bff3dae248042869b5678 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.92 2001/11/05 21:21:12 cph Exp $
+;;; $Id: imail.pkg,v 1.93 2001/11/06 04:45:45 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -266,12 +266,15 @@
   (export (edwin imail)
          imail-ui:body-cache-limit
          imail-ui:call-with-pass-phrase
+         imail-ui:clear-message
          imail-ui:delete-stored-pass-phrase
+         imail-ui:message
          imail-ui:message-wrapper
          imail-ui:present-user-alert
          imail-ui:progress-meter
          imail-ui:prompt-for-alist-value
-         imail-ui:prompt-for-yes-or-no?))
+         imail-ui:prompt-for-yes-or-no?
+         imail-ui:sit-for))
 
 (define-package (edwin imail front-end summary)
   (files "imail-summary")

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 10af96146e6556ff7fe445af2a6241e433f985f6..c55aa4bb4e5fcfe9fee8c88cd44e91199cc67cc6 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,14 +1,11 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.134 2001/09/30 15:10:22 cph Exp $
+$Id: todo.txt,v 1.135 2001/11/06 04:48:23 cph Exp $
 
 Bug fixes
 ---------
 
 * Remove cache for folders that aren't on server any more.
 
-* Add locking to cache so that two processes don't try to
-  write into it simultaneously.
-
 * When browser pops up a window of URLs that it is operating on, the
   strings shown should be relative to the container being browsed.