;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.36 2000/05/02 22:12:39 cph Exp $
+;;; $Id: imail-core.scm,v 1.37 2000/05/03 19:29:33 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
\f
;;;; Server operations
-;;; In "online" mode, these server operations directly modify the
-;;; server's state.
-
-;;; In "disconnected" mode, server operations don't interact with the
-;;; server, but instead manipulate locally-cached copies of folders
-;;; that reside on the server. The operations are recorded and saved
-;;; in the file system, then played back when SYNCHRONIZE-FOLDER is
-;;; called. In this mode, SYNCHRONIZE-FOLDER and POLL-FOLDER are the
-;;; only operations that interact with the server.
-
-;;; [**** Note that SYNCHRONIZE-FOLDER is insufficient to properly
-;;; implement "disconnected" mode. The client must also know how to
-;;; enumerate the server's folder set, so that it can tell whether a
-;;; given cached folder has been deleted or renamed on the server.
-;;; Similarly, the SYNCHRONIZE-FOLDER operation must be able to tell
-;;; the client that the folder being synchronized has been deleted or
-;;; renamed, so that the client can take appropriate action.]
-
;; -------------------------------------------------------------------
;; Create a new folder named URL. Signal an error if the folder
;; already exists or can't be created.
(define-class <folder> ()
(url define accessor)
- (modified? define standard
- initial-value #t)
+ (modification-count define standard
+ initial-value 0)
(modification-event define accessor
initial-value (make-event-distributor))
(properties define standard
(folder-url folder))
(define (folder-modified! folder)
- (if (not (folder-modified? folder))
- (begin
- (set-folder-modified?! folder #t)
- (event-distributor/invoke! (folder-modification-event folder)
- folder))))
-
-(define (folder-not-modified! folder)
- (if (folder-modified? folder)
- (begin
- (let ((count (folder-length folder)))
- (do ((index 0 (+ index 1)))
- ((= index count))
- (message-not-modified! (get-message folder index))))
- (set-folder-modified?! folder #f)
- (event-distributor/invoke! (folder-modification-event folder)
- folder))))
+ (without-interrupts
+ (lambda ()
+ (set-folder-modification-count!
+ folder
+ (+ (folder-modification-count folder) 1))))
+ (event-distributor/invoke! (folder-modification-event folder) folder))
(define (get-memoized-folder url)
(let ((folder (hash-table/get memoized-folders url #f)))
;; of the folder must work, but may incur a significant time or space
;; penalty.
-(define (close-folder folder)
- (%close-folder folder))
-
-(define-generic %close-folder (folder))
+(define-generic close-folder (folder))
;; -------------------------------------------------------------------
;; Return #T if FOLDER represents a real folder, i.e. has a
(%get-message folder index))
(define-generic %get-message (folder index))
-
+\f
;; -------------------------------------------------------------------
;; Insert a copy of MESSAGE in FOLDER at the end of the existing
;; messages. Unspecified result.
-(define (append-message folder message)
- (guarantee-message message 'APPEND-MESSAGE)
- (%append-message folder message))
+(define-generic append-message (folder message))
-(define-generic %append-message (folder message))
-\f
;; -------------------------------------------------------------------
;; Remove all messages in FOLDER that are marked for deletion.
;; Unspecified result.
(define-generic search-folder (folder criteria))
;; -------------------------------------------------------------------
-;; Poll the inbox associated with FOLDER to see if there is new mail.
-;; If so, the mail is appended to FOLDER. Return the number of new
-;; messages. Return #F if FOLDER has no associated inbox.
+;; Compare FOLDER's cache with the persistent folder and return a
+;; symbol indicating whether they are synchronized, as follows:
+;; SYNCHRONIZED FOLDER-MODIFIED PERSISTENT-MODIFIED BOTH-MODIFIED
+;; PERSISTENT-DELETED UNSYNCHRONIZED
-(define-generic poll-folder (folder))
+(define-generic folder-sync-status (folder))
;; -------------------------------------------------------------------
-;; Synchronize the local copy of FOLDER with the server's copy.
-;; Unspecified result.
+;; Save any cached changes made to FOLDER.
-(define-generic synchronize-folder (folder))
+(define-generic save-folder (folder))
;; -------------------------------------------------------------------
-;; Save any changes made to FOLDER. This permits the use of caches
-;; for improved performance.
-
-(define (save-folder folder)
- (%save-folder folder))
+;; Discard cached contents of FOLDER. Subsequent use of FOLDER will
+;; reload contents from the persistent folder.
-(define-generic %save-folder (folder))
-
-;; -------------------------------------------------------------------
-;; Check to see if the persistent copy of FOLDER has changed since it
-;; was copied into memory, and update the memory copy if so. Return
-;; #t if the memory copy is updated, #f if it is not. If both
-;; the memory copy and the persistent copy have changed, the procedure
-;; RESOLVE-CONFLICT is called with the folder as an argument.
-;; RESOLVE-CONFLICT must return a boolean which if true indicates that
-;; the folder should be reverted.
-
-(define (maybe-revert-folder folder resolve-conflict)
- (%maybe-revert-folder folder resolve-conflict))
-
-(define-generic %maybe-revert-folder (folder resolve-conflict))
-(define-generic %revert-folder (folder))
+(define-generic discard-folder-cache (folder))
\f
;;;; Message type
(header-fields define accessor)
(body define accessor)
(flags define standard)
- (modified? define standard
- initial-value #t)
+ (modification-count define standard
+ initial-value 0)
(properties define standard)
(folder define standard
initial-value #f)
(define (message-modified! message)
(without-interrupts
(lambda ()
- (set-message-modified?! message #t)
+ (set-message-modification-count!
+ message
+ (+ (message-modification-count message) 1))
(let ((folder (message-folder message)))
(if folder
(folder-modified! folder))))))
-(define (message-not-modified! message)
- (set-message-modified?! message #f))
-
(define (message->string message)
(string-append (header-fields->string (message-header-fields message))
"\n"
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.14 2000/05/02 22:12:59 cph Exp $
+;;; $Id: imail-file.scm,v 1.15 2000/05/03 19:29:37 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(messages define standard
accessor %file-folder-messages
initial-value 'UNKNOWN)
- (modification-time define standard initial-value #f))
+ (file-modification-time define standard
+ initial-value #f)
+ (file-modification-count define standard
+ initial-value #f))
(define (file-folder-messages folder)
(if (eq? 'UNKNOWN (%file-folder-messages folder))
- (%revert-folder folder))
+ (revert-file-folder folder))
(%file-folder-messages folder))
(define (file-folder-pathname folder)
(file-url-pathname (folder-url folder)))
-(define (update-file-folder-modification-time! folder)
- (set-file-folder-modification-time!
- folder
- (file-modification-time (file-folder-pathname folder)))
- (folder-not-modified! folder))
-
-(define-method %close-folder ((folder <file-folder>))
+(define-method close-folder ((folder <file-folder>))
(without-interrupts
(lambda ()
(let ((messages (%file-folder-messages folder)))
(define-method %get-message ((folder <file-folder>) index)
(list-ref (file-folder-messages folder) index))
-(define-method %append-message ((folder <file-folder>) message)
+(define-method append-message ((folder <file-folder>) (message <message>))
(let ((message (attach-message message folder)))
(without-interrupts
(lambda ()
(error:wrong-type-argument criteria
"search criteria"
'SEARCH-FOLDER))))
-
-(define-method synchronize-folder ((folder <file-folder>))
- folder
- unspecific)
-
-(define-method %maybe-revert-folder ((folder <file-folder>) resolve-conflict)
- (if (if (eqv? (file-folder-modification-time folder)
- (file-modification-time (file-folder-pathname folder)))
- (or (not (folder-modified? folder))
- (resolve-conflict folder))
- (folder-modified? folder))
- (%revert-folder folder)))
\ No newline at end of file
+\f
+(define-generic revert-file-folder (folder))
+
+(define-method folder-sync-status ((folder <file-folder>))
+ (let ((sync-time (file-folder-file-modification-time folder))
+ (sync-count (file-folder-file-modification-count folder))
+ (current-count (folder-modification-count folder))
+ (current-time (file-modification-time (file-folder-pathname folder))))
+ (if (and sync-time sync-count)
+ (if current-time
+ (if (= sync-time current-time)
+ (if (= sync-count current-count)
+ 'SYNCHRONIZED
+ 'FOLDER-MODIFIED)
+ (if (= sync-count current-count)
+ 'PERSISTENT-MODIFIED
+ 'BOTH-MODIFIED))
+ 'PERSISTENT-DELETED)
+ 'UNSYNCHRONIZED)))
+
+(define (synchronize-file-folder-write folder writer)
+ (let ((pathname (file-folder-pathname folder)))
+ (let loop ()
+ (let ((count (folder-modification-count folder)))
+ (writer folder pathname)
+ (let ((t (file-modification-time pathname)))
+ (if (and t (= count (folder-modification-count folder)))
+ (begin
+ (set-file-folder-file-modification-count! folder count)
+ (set-file-folder-file-modification-time! folder t))
+ (loop)))))))
+
+(define (synchronize-file-folder-read folder reader)
+ (let ((pathname (file-folder-pathname folder)))
+ (let loop ()
+ (let ((t (file-modification-time pathname)))
+ (reader folder pathname)
+ (if (= t (file-modification-time pathname))
+ (begin
+ (set-file-folder-file-modification-time! folder t)
+ (set-file-folder-file-modification-count!
+ folder
+ (folder-modification-count folder)))
+ (loop))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-imap.scm,v 1.11 2000/05/02 22:13:00 cph Exp $
+;;; $Id: imail-imap.scm,v 1.12 2000/05/03 19:29:39 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(begin
(guarantee-imap-connection-open connection)
connection)
- (loop (weak-cdr connections) alist))
+ (loop (weak-cdr connections) connections))
(let ((next (weak-cdr connections)))
(if prev
(weak-set-cdr! prev next)
(select-imap-folder connection #f))
folder)))
-(define-method %close-folder ((folder <imap-folder>))
+(define-method close-folder ((folder <imap-folder>))
(close-imap-connection (imap-folder-connection folder)))
(define-method %folder-valid? ((folder <imap-folder>))
(and unseen
(get-message folder unseen))))
-(define-method %append-message ((folder <imap-folder>) message)
+(define-method append-message ((folder <imap-folder>) (message <message>))
???)
(define-method expunge-deleted-messages ((folder <imap-folder>))
(define-method search-folder ((folder <imap-folder>) criteria)
???)
-(define-method poll-folder ((folder <imap-folder>))
- (imap:command:noop (imap-folder-connection folder))
- #f)
-
-(define-method synchronize-folder ((folder <imap-folder>))
- ???)
-
-(define-method %save-folder ((folder <imap-folder>))
- ???)
+(define-method folder-sync-status ((folder <imap-folder>))
+ ;; Changes are always written through.
+ folder
+ 'SYNCHRONIZED)
-(define-method %maybe-revert-folder ((folder <imap-folder>) resolve-conflict)
- ???)
+(define-method save-folder ((folder <imap-folder>))
+ ;; Changes are always written through.
+ folder
+ unspecific)
-(define-method %revert-folder ((folder <imap-folder>))
- ???)
+(define-method discard-folder-cache ((folder <imap-folder>))
+ (close-imap-connection (imap-folder-connection folder)))
\f
;;;; IMAP command invocation
(write command port)
(for-each (lambda (argument)
(write-char #\space port)
- (imap:send-command-argument connection tag command argument))
+ (imap:send-command-argument connection tag argument))
arguments)
(write-char #\return port)
(write-char #\linefeed port)
(flush-output port)
tag))
-(define (imap:send-command-argument connection tag command argument)
+(define (imap:send-command-argument connection tag argument)
(let ((port (imap-connection-port connection)))
(let loop ((argument argument))
(cond ((or (symbol? argument)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.21 2000/05/02 22:13:01 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.22 2000/05/03 19:29:42 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-method rmail-folder-header-fields ((folder <folder>))
(compute-rmail-folder-header-fields folder))
-(define-method %save-folder ((folder <rmail-folder>))
- (write-rmail-file folder (file-folder-pathname folder))
- (update-file-folder-modification-time! folder))
-
-(define-method poll-folder ((folder <rmail-folder>))
- (rmail-get-new-mail folder))
+(define-method save-folder ((folder <rmail-folder>))
+ (synchronize-file-folder-write folder write-rmail-file))
(define (compute-rmail-folder-header-fields folder)
(list (make-header-field "Version" " 5")
\f
;;;; Read RMAIL file
-(define-method %revert-folder ((folder <rmail-folder>))
- (call-with-binary-input-file (file-folder-pathname folder)
- (lambda (port)
- (set-rmail-folder-header-fields! folder (read-rmail-prolog port))
- (let loop ()
- (let ((message (read-rmail-message port)))
- (if message
- (begin
- (append-message folder message)
- (loop)))))))
- (update-file-folder-modification-time! folder))
+(define-method revert-file-folder ((folder <rmail-folder>))
+ (synchronize-file-folder-read folder
+ (lambda (folder pathname)
+ (without-interrupts
+ (lambda ()
+ (let ((messages (%file-folder-messages folder)))
+ (if (not (eq? 'UNKNOWN messages))
+ (for-each detach-message messages)))
+ (set-file-folder-messages! folder '())))
+ (call-with-binary-input-file pathname
+ (lambda (port)
+ (set-rmail-folder-header-fields! folder (read-rmail-prolog port))
+ (let loop ()
+ (let ((message (read-rmail-message port)))
+ (if message
+ (begin
+ (append-message folder message)
+ (loop))))))))))
(define (read-rmail-prolog port)
(if (not (string-prefix? "BABYL OPTIONS:" (read-required-line port)))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.27 2000/05/02 22:19:34 cph Exp $
+;;; $Id: imail-top.scm,v 1.28 2000/05/03 19:29:44 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;
;;; * Build generic message cache? Need to figure out when cached
;;; info can be deleted.
-;;;
-;;; * The following operations are all ways of doing synchronization,
-;;; so try to figure out a more unified viewpoint: POLL-FOLDER,
-;;; SYNCHRONIZE-FOLDER, SAVE-FOLDER, MAYBE-REVERT-FOLDER,
-;;; REVERT-FOLDER.
(declare (usual-integrations))
\f
(let ((buffer (new-buffer (imail-url->buffer-name url))))
(associate-imail-folder-with-buffer folder buffer)
(select-message folder (first-unseen-message folder) #t)
- buffer))))))
- (if (not url-string)
- ((ref-command imail-get-new-mail) #f))))
+ buffer))))))))
(define (imail-authenticator host user-id receiver)
(call-with-pass-phrase (string-append "Password for user " user-id
(define (imail-url->buffer-name url)
(url-body url))
\f
-(define-command imail-get-new-mail
- "Get new mail from this folder's inbox."
- ()
- (lambda ()
- (let ((folder (selected-folder)))
- (tl-maybe-revert-folder folder)
- (let ((n-new (poll-folder folder)))
- (cond ((not n-new)
- (message "(This folder has no associated inbox.)"))
- ((= 0 n-new)
- (message "(No new mail has arrived.)"))
- (else
- (select-message folder (- (folder-length folder) n-new))
- (event-distributor/invoke! (ref-variable imail-new-mail-hook))
- (message n-new
- " new message"
- (if (= n-new 1) "" "s")
- " read")))))))
-
-(define (tl-maybe-revert-folder folder)
- (maybe-revert-folder folder
- (lambda (folder)
- (prompt-for-yes-or-no?
- (string-append
- "Persistent copy of folder has changed since last read. "
- (if (folder-modified? folder)
- "Discard your changes"
- "Re-read folder"))))))
-
-(define-variable imail-new-mail-hook
- "An event distributor that is invoked when IMAIL incorporates new mail."
- (make-event-distributor))
-\f
(define-major-mode imail read-only "IMAIL"
"IMAIL mode is used by \\[imail] for editing IMAIL files.
All normal editing commands are turned off.
\\[imail-quit] Quit IMAIL: save, then switch to another buffer.
-\\[imail-get-new-mail] Read any new mail from the associated inbox into this folder.
-
\\[imail-mail] Mail a message (same as \\[mail-other-window]).
\\[imail-reply] Reply to this message. Like \\[imail-mail] but initializes some fields.
\\[imail-forward] Forward this message to another user.
(define-key 'imail #\x 'imail-expunge)
(define-key 'imail #\s 'imail-save-folder)
-(define-key 'imail #\g 'imail-get-new-mail)
(define-key 'imail #\c-m-h 'imail-summary)
(define-key 'imail #\c-m-l 'imail-summary-by-flags)
(let ((folder (selected-folder #f buffer))
(message (selected-message #f buffer)))
(let ((index (and message (message-index message))))
- (if (or dont-confirm?
- (prompt-for-yes-or-no?
- (string-append "Revert buffer from folder "
- (url->string (folder-url folder)))))
- (select-message
- folder
- (cond ((eq? folder (message-folder message)) message)
- ((and (<= 0 index) (< index (folder-length folder))) index)
- (else (first-unseen-message folder)))
- (tl-maybe-revert-folder folder))))))
+ (if (let ((status (folder-sync-status folder)))
+ (case status
+ ((UNSYNCHRONIZED)
+ #t)
+ ((SYNCHRONIZED PERSISTENT-MODIFIED)
+ (or dont-confirm?
+ (prompt-for-yes-or-no? "Revert buffer from folder")))
+ ((FOLDER-MODIFIED)
+ (prompt-for-yes-or-no? "Discard your changes to folder"))
+ ((BOTH-MODIFIED)
+ (prompt-for-yes-or-no?
+ "Persistent copy of folder changed; discard your changes"))
+ ((PERSISTENT-DELETED)
+ (editor-error "Persistent copy of folder deleted."))
+ (else
+ (error "Unknown folder-sync status:" status))))
+ (begin
+ (discard-folder-cache folder)
+ (select-message
+ folder
+ (cond ((eq? folder (message-folder message)) message)
+ ((and (<= 0 index) (< index (folder-length folder))) index)
+ (else (first-unseen-message folder)))
+ #t))))))
(define (imail-kill-buffer buffer)
(let ((folder (selected-folder #f buffer)))
()
(lambda ()
(save-folder (selected-folder))))
-
-(define-command imail-synchronize
- "Synchronize the current folder with the master copy on the server.
-Currently meaningless for file-based folders."
- ()
- (lambda ()
- (synchronize-folder (selected-folder))))
\f
;;;; Navigation
(let ((folder (open-folder url-string))
(message (selected-message)))
(append-message folder message)
- (save-folder folder)
- (set-message-flag message "filed"))
- (if (ref-variable imail-delete-after-output)
- ((ref-command imail-delete-forward) #f))))
+ (set-message-flag message "filed")
+ (if (ref-variable imail-delete-after-output)
+ ((ref-command imail-delete-forward) #f))
+ (save-folder folder))))
\f
;;;; Sending mail
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.15 2000/05/02 22:13:03 cph Exp $
+;;; $Id: imail-umail.scm,v 1.16 2000/05/03 19:29:48 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-class (<umail-folder> (constructor (url))) (<file-folder>))
-(define-method %save-folder ((folder <umail-folder>))
- (write-umail-file folder (file-folder-pathname folder))
- (update-file-folder-modification-time! folder))
-
-(define-method poll-folder ((folder <umail-folder>))
- folder
- #f)
+(define-method save-folder ((folder <umail-folder>))
+ (synchronize-file-folder-write folder write-umail-file))
\f
;;;; Read unix mail file
-(define-method %revert-folder ((folder <umail-folder>))
- (set-file-folder-messages!
- folder
- (call-with-binary-input-file (file-folder-pathname folder)
- (lambda (port)
- (let ((from-line (read-line port)))
- (if (eof-object? from-line)
- '()
- (begin
- (if (not (umail-delimiter? from-line))
- (error "Malformed unix mail file:" port))
- (let loop ((from-line from-line) (messages '()))
- (call-with-values
- (lambda () (read-umail-message from-line port))
- (lambda (message from-line)
- (let ((messages (cons message messages)))
- (if from-line
- (loop from-line messages)
- (reverse! messages))))))))))))
- (update-file-folder-modification-time! folder))
-
-(define (read-umail-message from-line port)
+(define-method revert-file-folder ((folder <umail-folder>))
+ (synchronize-file-folder-read folder
+ (lambda (folder pathname)
+ (set-file-folder-messages!
+ folder
+ (call-with-binary-input-file pathname
+ (lambda (port)
+ (let ((from-line (read-line port)))
+ (if (eof-object? from-line)
+ '()
+ (begin
+ (if (not (umail-delimiter? from-line))
+ (error "Malformed unix mail file:" port))
+ (let loop ((from-line from-line) (messages '()))
+ (call-with-values
+ (lambda ()
+ (read-umail-message folder from-line port))
+ (lambda (message from-line)
+ (let ((messages (cons message messages)))
+ (if from-line
+ (loop from-line messages)
+ (reverse! messages)))))))))))))))
+
+(define (read-umail-message folder from-line port)
(let read-headers ((header-lines '()))
(let ((line (read-line port)))
(cond ((eof-object? line)
- (values (make-umail-message from-line
+ (values (make-umail-message folder
+ from-line
(reverse! header-lines)
'())
#f))
(let read-body ((body-lines '()))
(let ((line (read-line port)))
(cond ((eof-object? line)
- (values (make-umail-message from-line
+ (values (make-umail-message folder
+ from-line
(reverse! header-lines)
(reverse! body-lines))
#f))
((umail-delimiter? line)
- (values (make-umail-message from-line
+ (values (make-umail-message folder
+ from-line
(reverse! header-lines)
(reverse! body-lines))
line))
(else
(read-headers (cons line header-lines)))))))
-(define (make-umail-message from-line header-lines body-lines)
+(define (make-umail-message folder from-line header-lines body-lines)
(let ((message
- (make-detached-message
+ (make-attached-message
+ folder
(lines->header-fields header-lines)
(lines->string (map (lambda (line)
(if (string-prefix-ci? ">From " line)
projects / mit-scheme.git / commitdiff