From: Taylor R. Campbell Date: Sun, 18 May 2008 23:58:38 +0000 (+0000) Subject: Enhance preloading of folder outlines for IMAP folders, and implement X-Git-Tag: 20090517-FFI~295 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=556534faf082d81d62899613144fcdecebbe0d85;p=mit-scheme.git Enhance preloading of folder outlines for IMAP folders, and implement caching of entire folders' contents. PRELOAD-FOLDER-OUTLINES on IMAP folders will now be much cleverer (read: not stupid) about what items to fetch for what messages, so that we fetch only what we need from each message. This means that summary buffer generation will now spend much less time (i.e. as much time as it did six months ago) fetching message items. New generic procedure CACHE-FOLDER-CONTENTS works similarly to PRELOAD-FOLDER-OUTLINES, but also fetches requested body parts of messages. New Edwin command IMAIL-CACHE uses CACHE-FOLDER-CONTENTS to fill the cache of the selected folder. The front end's generic procedure WALK-MIME-MESSAGE-PART is now a little more general, so that it can be used to work together with with CACHE-FOLDER-CONTENTS. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index ba689d7b9..318f746e8 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -595,6 +595,26 @@ USA. ;; enhancement. (define-generic preload-folder-outlines (folder)) + +(define-method preload-folder-outlines ((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 ) walk-mime-body) + folder walk-mime-body ;ignore + unspecific) ;;;; Message type diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index ac0c140db..e227524f0 100644 --- 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.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, @@ -1189,52 +1189,61 @@ USA. (number->string (+ (%message-index message) 1)))) keyword)) -;;;; 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 )) - (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 ) 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))))) + +(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 '())) @@ -1251,6 +1260,31 @@ USA. (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))))) ;;;; MIME support @@ -1261,16 +1295,18 @@ USA. (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 ) 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) @@ -1592,6 +1628,22 @@ USA. (imap-message-uid message) keywords)))))))) +(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 diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 9f8712bfd..58c51baf7 100644 --- 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.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, @@ -429,7 +429,9 @@ Instead, these commands are available: 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.") (define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?) dont-use-auto-save? @@ -1748,6 +1750,36 @@ Negative argument means search in reverse." (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))))))) ;;;; URLs @@ -2324,7 +2356,9 @@ Negative argument means search in reverse." 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) @@ -2386,14 +2420,13 @@ Negative argument means search in reverse." encoding (mime-body-one-part-encoding body)))) -(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 ) selector context mark) - ((if (inline-message-part? body context mark) - insert-mime-message-inline - insert-mime-message-outline) + (message (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 ) context mark) @@ -2429,7 +2462,8 @@ Negative argument means search in reverse." (< (mime-body-one-part-n-octets body) limit))))) (define-method walk-mime-message-part - (message (body ) selector context mark) + (message (body ) selector context + mark if-inline if-outline) (let ((context (make-walk-mime-subcontext context @@ -2446,16 +2480,16 @@ Negative argument means search in reverse." (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)) @@ -2463,7 +2497,7 @@ Negative argument means search in reverse." (car parts) `(,@selector ,i) context - mark))))) + mark if-inline if-outline))))) (define (insert-mime-message-inline message body selector context mark) (maybe-insert-mime-boundary context mark) @@ -2555,7 +2589,9 @@ Negative argument means search in reverse." (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)) diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg index 9e10093fb..30f2b81eb 100644 --- a/v7/src/imail/imail.pkg +++ b/v7/src/imail/imail.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: imail.pkg,v 1.104 2008/01/30 20:02:10 cph Exp $ +$Id: imail.pkg,v 1.105 2008/05/18 23:58:38 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -184,6 +184,7 @@ USA. edwin-command$imail edwin-command$imail-add-flag edwin-command$imail-bury + edwin-command$imail-cache edwin-command$imail-continue edwin-command$imail-copy-folder edwin-command$imail-create-folder