#| -*-Scheme-*-
-$Id: imail-core.scm,v 1.168 2008/02/12 00:37:54 riastradh Exp $
+$Id: imail-core.scm,v 1.169 2008/05/18 23:58:37 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; enhancement.
(define-generic preload-folder-outlines (folder))
+
+(define-method preload-folder-outlines ((folder <folder>))
+ folder ;ignore
+ unspecific)
+
+;; -------------------------------------------------------------------
+;; Cache the entire contents of the folder locally, including the
+;; outline and body text. For messages that have MIME body
+;; structures, CACHE-FOLDER-CONTENTS passes the message, its body
+;; structure and a procedure to WALK-MIME-BODY, which should apply the
+;; procedure to each section of the message that should be cached.
+;;
+;; This is like PRELOAD-FOLDER-OUTLINES, and also need not be
+;; implemented.
+
+(define-generic cache-folder-contents (folder walk-mime-body))
+
+(define-method cache-folder-contents ((folder <folder>) walk-mime-body)
+ folder walk-mime-body ;ignore
+ unspecific)
\f
;;;; Message type
#| -*-Scheme-*-
-$Id: imail-imap.scm,v 1.216 2008/02/11 22:45:43 riastradh Exp $
+$Id: imail-imap.scm,v 1.217 2008/05/18 23:58:37 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(number->string (+ (%message-index message) 1))))
keyword))
\f
-;;;; Preloading Folder Outlines
+;;;; Preloading Folder Outlines & Caching Folder Contents
-;;; This really wants to have an extra argument passed describing what
-;;; parts of the message we expect to use heavily soon; right now the
-;;; code is too much about how to preload the outlines. But I haven't
-;;; thought of a good way to express the `what' part, and I don't
-;;; really have time.
+(define outline-keywords
+ '(FLAGS INTERNALDATE RFC822.HEADER RFC822.SIZE))
(define-method preload-folder-outlines ((folder <imap-folder>))
- (let ((messages '()) (total-length (folder-length folder)))
- (with-folder-locked folder
- (lambda ()
- ((imail-ui:message-wrapper "Scanning message cache")
- (lambda ()
- (for-each-message folder
- (lambda (index message)
- (if (zero? (remainder index 10))
- (imail-ui:progress-meter index total-length))
- (if (not (message-outline-cached? message))
- (set! messages (cons message messages)))))))))
- (if (pair? messages)
- (let ((keywords imap-outline-cache-keywords)
- (connection (guarantee-imap-folder-open folder)))
- ((imail-ui:message-wrapper "Reading message headers")
- (lambda ()
- (let ((current 0) (total (length messages)))
- (imap:command:fetch-set/for-each
- (lambda (response)
- (if (zero? (remainder current 10))
- (imail-ui:progress-meter current total))
- (set! current (+ current 1))
- (cache-preload-response folder keywords response))
- connection
- (message-list->set (reverse! messages))
- keywords))))))))
-
-(define imap-outline-cache-keywords '(RFC822.HEADER))
-
-(define (message-outline-cached? message)
- (file-exists? (message-item-pathname message 'RFC822.HEADER)))
+ (fill-imap-message-cache folder outline-keywords))
+
+(define content-keywords
+ ;; I am not sure who, if anyone, uses the envelope, but the body
+ ;; structure is necessary in order to decide what parts to fetch.
+ ;; Omitting the envelope does not noticeably expedite the process.
+ (append '(BODYSTRUCTURE ENVELOPE) outline-keywords))
+
+(define-method cache-folder-contents ((folder <imap-folder>) walk-mime-body)
+ (fill-imap-message-cache folder content-keywords)
+ (let ((length (folder-length folder)))
+ (for-each-message folder
+ (lambda (index message)
+ (if (zero? (remainder index 10))
+ (imail-ui:progress-meter index length))
+ (cond ((imap-message-bodystructure message)
+ => (lambda (body-structure)
+ (walk-mime-body message body-structure
+ (lambda (selector)
+ (fetch-message-body-part-to-cache
+ message
+ (mime-selector->imap-section selector))))))
+ (else
+ (fetch-message-body-part-to-cache message '(TEXT))))))))
(define (for-each-message folder procedure)
(let ((n (folder-length folder)))
(do ((i 0 (+ i 1)))
((= i n))
(procedure i (%get-message folder i)))))
+\f
+(define (fill-imap-message-cache folder keywords)
+ (receive (message-sets total-count) (scan-imap-message-cache folder keywords)
+ (if (positive? total-count)
+ (let ((connection (guarantee-imap-folder-open folder))
+ (count 0))
+ ((imail-ui:message-wrapper "Reading message data")
+ (lambda ()
+ (hash-table/for-each message-sets
+ (lambda (keywords messages)
+ (imap:command:fetch-set/for-each
+ (lambda (response)
+ (if (zero? (remainder count 10))
+ (imail-ui:progress-meter count total-count))
+ (set! count (+ count 1))
+ (cache-preload-response folder keywords response))
+ connection
+ (message-list->set (reverse! messages))
+ keywords)))))))))
(define (message-list->set messages)
(let loop ((indexes (map %message-index messages)) (groups '()))
(number->string (+ this 1))))
groups)))))
(decorated-string-append "" "," "" (reverse! groups)))))
+
+(define (scan-imap-message-cache folder keywords)
+ (let ((message-sets (make-equal-hash-table))
+ (length (folder-length folder))
+ (count 0))
+ (with-folder-locked folder
+ (lambda ()
+ ((imail-ui:message-wrapper "Scanning message cache")
+ (lambda ()
+ (for-each-message folder
+ (lambda (index message)
+ (if (zero? (remainder index 10))
+ (imail-ui:progress-meter index length))
+ (let ((keywords (message-uncached-keywords message keywords)))
+ (if (pair? keywords)
+ (begin
+ (hash-table/modify! message-sets keywords
+ (lambda (messages) (cons message messages))
+ '())
+ (set! count (+ count 1)))))))))))
+ (values message-sets count)))
+
+(define (message-uncached-keywords message keywords)
+ (delete-matching-items keywords
+ (lambda (keyword) (file-exists? (message-item-pathname message keyword)))))
\f
;;;; MIME support
(write-mime-message-body-part
message '(TEXT) (imap-message-length message) port))
+(define (mime-selector->imap-section selector)
+ (if (pair? selector)
+ (map (lambda (x)
+ (if (exact-nonnegative-integer? x)
+ (+ x 1)
+ x))
+ selector)
+ '(TEXT)))
+
(define-method write-mime-message-body-part
((message <imap-message>) selector cache? port)
- (let ((section
- (if (pair? selector)
- (map (lambda (x)
- (if (exact-nonnegative-integer? x)
- (+ x 1)
- x))
- selector)
- '(TEXT))))
+ (let ((section (mime-selector->imap-section selector)))
(let ((entry
(list-search-positive (imap-message-body-parts message)
(lambda (entry)
(imap-message-uid message)
keywords))))))))
\f
+(define (fetch-message-body-part-to-cache message section)
+ (let ((keyword (imap-body-section->keyword section)))
+ (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
+ (lambda (output-port)
+ (imap:bind-fetch-body-part-port output-port
+ (lambda ()
+ (fetch-message-body-part-1 message
+ section
+ keyword))))))))))))
+
(define (fetch-message-body-part-to-port message section port)
(let ((keyword (imap-body-section->keyword section)))
(let ((fetch-to-port
#| -*-Scheme-*-
-$Id: imail-top.scm,v 1.303 2008/02/10 10:06:51 riastradh Exp $
+$Id: imail-top.scm,v 1.304 2008/05/18 23:58:37 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
create folders automatically.)
\\[imail-delete-folder] Delete an existing folder and all its messages.
\\[imail-rename-folder] Rename a folder.
-\\[imail-copy-folder] Copy all messages from one folder to another.")
+\\[imail-copy-folder] Copy all messages from one folder to another.
+
+\\[imail-cache] Fill any local cache associated with the selected folder.")
\f
(define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?)
dont-use-auto-save?
(select-message folder index)
(message msg "done"))
(editor-failure "Search failed: " pattern))))))
+
+(define-command imail-cache
+ "Fill any local cache associated with the selected folder.
+By default, fetch only parts that would ordinarily be displayed by
+ default in-line.
+With a prefix argument, fetch every part of every message, whether or
+ not it would ordinarily be displayed in-line.
+WARNING: With a prefix argument, this command may take a very long
+ time to complete if there are many immense attachments in the
+ folder."
+ "P"
+ (lambda (argument)
+ (cache-folder-contents
+ (selected-folder)
+ (let ((buffer (selected-buffer)))
+ (lambda (message body-structure cache-procedure)
+ (define (cache message body selector context buffer)
+ message body context buffer
+ (cache-procedure selector))
+ (define (ignore message body selector context buffer)
+ message body selector context buffer
+ unspecific)
+ (walk-mime-message-part
+ message
+ body-structure
+ '()
+ (make-walk-mime-context #f 0 #f '())
+ buffer
+ cache
+ (if argument cache ignore)))))))
\f
;;;; URLs
body-structure
'()
(make-walk-mime-context inline-only? left-margin #f '())
- mark))
+ mark
+ insert-mime-message-inline
+ insert-mime-message-outline))
(define-structure walk-mime-context
(inline-only? #f read-only #t)
encoding
(mime-body-one-part-encoding body))))
\f
-(define-generic walk-mime-message-part (message body selector context mark))
+(define-generic walk-mime-message-part
+ (message body selector context mark if-inline if-outline))
(define-generic inline-message-part? (body context mark))
(define-method walk-mime-message-part
- (message (body <mime-body>) selector context mark)
- ((if (inline-message-part? body context mark)
- insert-mime-message-inline
- insert-mime-message-outline)
+ (message (body <mime-body>) selector context mark if-inline if-outline)
+ ((if (inline-message-part? body context mark) if-inline if-outline)
message body selector context mark))
(define-method inline-message-part? ((body <mime-body>) context mark)
(< (mime-body-one-part-n-octets body) limit)))))
(define-method walk-mime-message-part
- (message (body <mime-body-multipart>) selector context mark)
+ (message (body <mime-body-multipart>) selector context
+ mark if-inline if-outline)
(let ((context
(make-walk-mime-subcontext
context
(car parts)
`(,@selector 0)
context
- mark)
+ mark if-inline if-outline)
(if (ref-variable imail-mime-show-alternatives mark)
(do ((parts (cdr parts) (cdr parts))
(i 1 (fix:+ i 1)))
((null? parts))
- (insert-mime-message-outline message
- (car parts)
- `(,@selector ,i)
- context
- mark)))))
+ (if-outline message
+ (car parts)
+ `(,@selector ,i)
+ context
+ mark)))))
(do ((parts parts (cdr parts))
(i 0 (fix:+ i 1)))
((null? parts))
(car parts)
`(,@selector ,i)
context
- mark)))))
+ mark if-inline if-outline)))))
\f
(define (insert-mime-message-inline message body selector context mark)
(maybe-insert-mime-boundary context mark)
(mime-body-message-body body)
selector
(make-walk-mime-subcontext context body #f)
- mark))
+ mark
+ insert-mime-message-inline
+ insert-mime-message-outline))
(define-generic compute-mime-message-outline (body name context))
projects / mit-scheme.git / commitdiff