Commit | Line | Data |
---|---|---|
3d994264 TZ |
1 | ;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox |
2 | ||
49f70d46 | 3 | ;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. |
3d994264 TZ |
4 | |
5 | ;; Author: Teodor Zlatanov <tzz@lifelogs.com> | |
6 | ;; Keywords: mail | |
7 | ||
8 | ;; This program is free software; you can redistribute it and/or modify | |
9 | ;; it under the terms of the GNU General Public License as published by | |
10 | ;; the Free Software Foundation, either version 3 of the License, or | |
11 | ;; (at your option) any later version. | |
12 | ||
13 | ;; This program is distributed in the hope that it will be useful, | |
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;; GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public License | |
19 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | ;;; Commentary: | |
22 | ||
23 | ;; This module provides hashtable-like functions on top of imap.el | |
24 | ;; functionality. All the authentication is handled by auth-source so | |
25 | ;; there are no authentication options here, only the server and | |
26 | ;; mailbox names are needed. | |
27 | ||
28 | ;; Create a IHT (imap-hash table) object with `imap-hash-make'. Then | |
29 | ;; use it with `imap-hash-map' to map a function across all the | |
30 | ;; messages. Use `imap-hash-get' and `imap-hash-rem' to operate on | |
31 | ;; individual messages. See the tramp-imap.el library in Tramp if you | |
32 | ;; need to see practical examples. | |
33 | ||
34 | ;; This only works with IMAP4r1. Sorry to everyone without it, but | |
35 | ;; the compatibility code is too annoying and it's 2009. | |
36 | ||
37 | ;; TODO: Use SEARCH instead of FETCH when a test is specified. List | |
38 | ;; available mailboxes. Don't select an invalid mailbox. | |
39 | ||
40 | ;;; Code: | |
41 | ||
42 | (require 'assoc) | |
43 | (require 'imap) | |
44 | (require 'sendmail) ; for mail-header-separator | |
45 | (require 'message) | |
46 | (autoload 'auth-source-user-or-password "auth-source") | |
47 | ||
48 | ;; retrieve these headers | |
49 | (defvar imap-hash-headers | |
50 | (append '(Subject From Date Message-Id References In-Reply-To Xref))) | |
51 | ||
52 | ;; from nnheader.el | |
53 | (defsubst imap-hash-remove-cr-followed-by-lf () | |
54 | (goto-char (point-max)) | |
55 | (while (search-backward "\r\n" nil t) | |
56 | (delete-char 1))) | |
57 | ||
58 | ;; from nnheader.el | |
59 | (defun imap-hash-ms-strip-cr (&optional string) | |
60 | "Strip ^M from the end of all lines in current buffer or STRING." | |
61 | (if string | |
62 | (with-temp-buffer | |
63 | (insert string) | |
64 | (imap-hash-remove-cr-followed-by-lf) | |
65 | (buffer-string)) | |
66 | (save-excursion | |
67 | (imap-hash-remove-cr-followed-by-lf)))) | |
68 | ||
69 | (defun imap-hash-make (server port mailbox &optional user password ssl) | |
0472835f JB |
70 | "Make a new imap-hash object using SERVER, PORT, and MAILBOX. |
71 | USER, PASSWORD and SSL are optional. | |
3d994264 TZ |
72 | The test is set to t, meaning all messages are considered." |
73 | (when (and server port mailbox) | |
0472835f JB |
74 | (list :server server :port port :mailbox mailbox |
75 | :ssl ssl :user user :password password | |
3d994264 TZ |
76 | :test t))) |
77 | ||
78 | (defun imap-hash-p (iht) | |
0472835f | 79 | "Check whether IHT is a valid imap-hash." |
3d994264 TZ |
80 | (and |
81 | (imap-hash-server iht) | |
82 | (imap-hash-port iht) | |
83 | (imap-hash-mailbox iht) | |
84 | (imap-hash-test iht))) | |
85 | ||
86 | (defmacro imap-hash-gather (uid) | |
87 | `(imap-message-get ,uid 'BODYDETAIL)) | |
88 | ||
89 | (defmacro imap-hash-data-body (details) | |
90 | `(nth 2 (nth 1 ,details))) | |
91 | ||
92 | (defmacro imap-hash-data-headers (details) | |
93 | `(nth 2 (nth 0 ,details))) | |
94 | ||
95 | (defun imap-hash-get (key iht &optional refetch) | |
96 | "Get the value for KEY in the imap-hash IHT. | |
97 | Requires either `imap-hash-fetch' to be called beforehand | |
0472835f | 98 | \(e.g. by `imap-hash-map'), or REFETCH to be t. |
3d994264 TZ |
99 | Returns a list of the headers (an alist, see `imap-hash-map') and |
100 | the body of the message as a string. | |
101 | Also see `imap-hash-test'." | |
102 | (with-current-buffer (imap-hash-get-buffer iht) | |
103 | (when refetch | |
104 | (imap-hash-fetch iht nil key)) | |
105 | (let ((details (imap-hash-gather key))) | |
106 | (list | |
107 | (imap-hash-get-headers | |
108 | (imap-hash-data-headers details)) | |
0472835f | 109 | (imap-hash-get-body |
3d994264 TZ |
110 | (imap-hash-data-body details)))))) |
111 | ||
112 | (defun imap-hash-put (value iht &optional key) | |
0472835f | 113 | "Put VALUE in the imap-hash IHT. Return the new key. |
3d994264 | 114 | If KEY is given, removes it. |
0472835f | 115 | VALUE can be a list of the headers (an alist, see `imap-hash-map') |
3d994264 TZ |
116 | and the body of the message as a string. It can also be a uid, |
117 | in which case `imap-hash-get' will be called to get the value. | |
118 | Also see `imap-hash-test'." | |
119 | (let ((server-buffer (imap-hash-get-buffer iht)) | |
120 | (value (if (listp value) value (imap-hash-get value iht))) | |
121 | newuid) | |
122 | (when value | |
123 | (with-temp-buffer | |
0472835f JB |
124 | (funcall 'imap-hash-make-message |
125 | (nth 0 value) | |
3d994264 TZ |
126 | (nth 1 value) |
127 | nil) | |
128 | (setq newuid (nth 1 (imap-message-append | |
0472835f | 129 | (imap-hash-mailbox iht) |
3d994264 TZ |
130 | (current-buffer) nil nil server-buffer))) |
131 | (when key (imap-hash-rem key iht)))) | |
132 | newuid)) | |
133 | ||
134 | (defun imap-hash-make-message (headers body &optional overrides) | |
135 | "Make a message with HEADERS and BODY suitable for `imap-append', | |
0472835f | 136 | using `message-setup'. |
3d994264 TZ |
137 | Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'." |
138 | ;; don't insert a signature no matter what | |
139 | (let (message-signature) | |
140 | (message-setup | |
141 | (append overrides headers)) | |
142 | (message-generate-headers message-required-mail-headers) | |
143 | (message-remove-header "X-Draft-From") | |
144 | (message-goto-body) | |
145 | (insert (or (aget overrides 'body) | |
146 | body | |
147 | "")) | |
148 | (goto-char (point-min)) | |
149 | ;; TODO: make this search better | |
150 | (if (search-forward mail-header-separator nil t) | |
151 | (delete-region (line-beginning-position) (line-end-position)) | |
152 | (error "Could not find the body separator in the encoded message!")))) | |
153 | ||
154 | (defun imap-hash-rem (key iht) | |
155 | "Remove KEY in the imap-hash IHT. | |
156 | Also see `imap-hash-test'. Requires `imap-hash-fetch' to have | |
0472835f | 157 | been called and the imap-hash server buffer to be current, |
3d994264 TZ |
158 | so it's best to use it inside `imap-hash-map'. |
159 | The key will not be found on the next `imap-hash-map' call." | |
160 | (with-current-buffer (imap-hash-get-buffer iht) | |
161 | (imap-message-flags-add | |
162 | (imap-range-to-message-set (list key)) | |
163 | "\\Deleted" 'silent) | |
164 | (imap-mailbox-expunge t))) | |
165 | ||
166 | (defun imap-hash-clear (iht) | |
167 | "Remove all keys in the imap-hash IHT. | |
168 | Also see `imap-hash-test'." | |
169 | (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht)) | |
170 | ||
171 | (defun imap-hash-get-headers (text-headers) | |
172 | (with-temp-buffer | |
173 | (insert (or text-headers "")) | |
174 | (imap-hash-remove-cr-followed-by-lf) | |
0472835f | 175 | (mapcar (lambda (header) |
3d994264 TZ |
176 | (cons header |
177 | (message-fetch-field (format "%s" header)))) | |
178 | imap-hash-headers))) | |
179 | ||
180 | (defun imap-hash-get-body (text) | |
181 | (with-temp-buffer | |
182 | (insert (or text "")) | |
183 | (imap-hash-remove-cr-followed-by-lf) | |
184 | (buffer-string))) | |
185 | ||
186 | (defun imap-hash-map (function iht &optional headers-only &rest messages) | |
187 | "Call FUNCTION for all entries in IHT and pass it the message uid, | |
188 | the headers (an alist, see `imap-hash-headers'), and the body | |
189 | contents as a string. If HEADERS-ONLY is not nil, the body will be nil. | |
190 | Returns results of evaluating, as would `mapcar'. | |
191 | If MESSAGES are given, iterate only over those UIDs. | |
192 | Also see `imap-hash-test'." | |
193 | (imap-hash-fetch iht headers-only) | |
194 | (let ((test (imap-hash-test iht))) | |
195 | (with-current-buffer (imap-hash-get-buffer iht) | |
196 | (delq nil | |
197 | (imap-message-map (lambda (message ignored-parameter) | |
198 | (let* ((details (imap-hash-gather message)) | |
199 | (headers (imap-hash-data-headers details)) | |
200 | (hlist (imap-hash-get-headers headers)) | |
201 | (runit (cond | |
0472835f | 202 | ((stringp test) |
3d994264 | 203 | (string-match |
0472835f | 204 | test |
3d994264 | 205 | (format "%s" (aget hlist 'Subject)))) |
0472835f | 206 | ((functionp test) |
3d994264 TZ |
207 | (funcall test hlist)) |
208 | ;; otherwise, return test itself | |
209 | (t test)))) | |
210 | ;;(debug message headers) | |
211 | (when runit | |
212 | (funcall function | |
213 | message | |
214 | (imap-hash-get-headers | |
215 | headers) | |
216 | (imap-hash-get-body | |
217 | (imap-hash-data-body details)))))) | |
218 | "UID"))))) | |
219 | ||
220 | (defun imap-hash-count (iht) | |
0472835f | 221 | "Count the number of messages in the imap-hash IHT. |
3d994264 TZ |
222 | Also see `imap-hash-test'. It uses `imap-hash-map' so just use that |
223 | function if you want to do more than count the elements." | |
224 | (length (imap-hash-map (lambda (a b c)) iht t))) | |
225 | ||
226 | (defalias 'imap-hash-size 'imap-hash-count) | |
227 | ||
228 | (defun imap-hash-test (iht) | |
0472835f | 229 | "Return the test used by `imap-hash-map' for IHT. |
3d994264 | 230 | When the test is t, any key will be a candidate. |
0472835f JB |
231 | When the test is a string, messages will be filtered on that string as a |
232 | regexp against the subject. | |
233 | When the test is a function, messages will be filtered with it. | |
3d994264 TZ |
234 | The function is passed the message headers (see `imap-hash-get-headers')." |
235 | (plist-get iht :test)) | |
236 | ||
0472835f JB |
237 | (defun imap-hash-server (iht) |
238 | "Return the server used by the imap-hash IHT." | |
3d994264 TZ |
239 | (plist-get iht :server)) |
240 | ||
0472835f JB |
241 | (defun imap-hash-port (iht) |
242 | "Return the port used by the imap-hash IHT." | |
3d994264 TZ |
243 | (plist-get iht :port)) |
244 | ||
0472835f JB |
245 | (defun imap-hash-ssl (iht) |
246 | "Return the SSL need for the imap-hash IHT." | |
3d994264 TZ |
247 | (plist-get iht :ssl)) |
248 | ||
249 | (defun imap-hash-mailbox (iht) | |
0472835f | 250 | "Return the mailbox used by the imap-hash IHT." |
3d994264 TZ |
251 | (plist-get iht :mailbox)) |
252 | ||
0472835f JB |
253 | (defun imap-hash-user (iht) |
254 | "Return the username used by the imap-hash IHT." | |
3d994264 TZ |
255 | (plist-get iht :user)) |
256 | ||
0472835f JB |
257 | (defun imap-hash-password (iht) |
258 | "Return the password used by the imap-hash IHT." | |
3d994264 TZ |
259 | (plist-get iht :password)) |
260 | ||
261 | (defun imap-hash-open-connection (iht) | |
262 | "Open the connection used for IMAP interactions with the imap-hash IHT." | |
263 | (let* ((server (imap-hash-server iht)) | |
264 | (port (imap-hash-port iht)) | |
265 | (ssl-need (imap-hash-ssl iht)) | |
0472835f | 266 | (auth-need (not (and (imap-hash-user iht) |
3d994264 TZ |
267 | (imap-hash-password iht)))) |
268 | ;; this will not be needed if auth-need is t | |
269 | (auth-info (when auth-need | |
0472835f JB |
270 | (auth-source-user-or-password |
271 | '("login" "password") | |
3d994264 | 272 | server port))) |
0472835f | 273 | (auth-user (or (imap-hash-user iht) |
3d994264 | 274 | (nth 0 auth-info))) |
0472835f | 275 | (auth-passwd (or (imap-hash-password iht) |
3d994264 TZ |
276 | (nth 1 auth-info))) |
277 | (imap-logout-timeout nil)) | |
278 | ||
279 | ;; (debug "opening server: opened+state" (imap-opened) imap-state) | |
280 | ;; this is the only place where IMAP vs IMAPS matters | |
281 | (if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer)) | |
282 | (progn | |
283 | ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state) | |
284 | ;; (debug "authenticating" auth-user auth-passwd) | |
285 | (if (not (imap-capability 'IMAP4rev1)) | |
0472835f | 286 | (error "IMAP server does not support IMAP4r1, it won't work, sorry") |
3d994264 TZ |
287 | (imap-authenticate auth-user auth-passwd) |
288 | (imap-id) | |
289 | ;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state) | |
290 | (imap-opened (current-buffer)))) | |
291 | (error "Could not open the IMAP buffer")))) | |
292 | ||
293 | (defun imap-hash-get-buffer (iht) | |
294 | "Get or create the connection buffer to be used for the imap-hash IHT." | |
295 | (let* ((name (imap-hash-buffer-name iht)) | |
296 | (buffer (get-buffer name))) | |
297 | (if (and buffer (imap-opened buffer)) | |
298 | buffer | |
299 | (when buffer (kill-buffer buffer)) | |
300 | (with-current-buffer (get-buffer-create name) | |
301 | (setq buffer-undo-list t) | |
302 | (when (imap-hash-open-connection iht) | |
303 | (current-buffer)))))) | |
304 | ||
305 | (defun imap-hash-buffer-name (iht) | |
306 | "Get the connection buffer to be used for the imap-hash IHT." | |
307 | (when (imap-hash-p iht) | |
308 | (let ((server (imap-hash-server iht)) | |
309 | (port (imap-hash-port iht)) | |
310 | (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL"))) | |
311 | (format "*imap-hash/%s:%s:%s*" server port ssl-text)))) | |
312 | ||
313 | (defun imap-hash-fetch (iht &optional headers-only &rest messages) | |
314 | "Fetch all the messages for imap-hash IHT. | |
315 | Get only the headers if HEADERS-ONLY is not nil." | |
316 | (with-current-buffer (imap-hash-get-buffer iht) | |
0472835f JB |
317 | (let ((range (if messages |
318 | (list | |
3d994264 TZ |
319 | (imap-range-to-message-set messages) |
320 | (imap-range-to-message-set messages)) | |
321 | '("1:*" . "1,*:*")))) | |
322 | ||
323 | ;; (with-current-buffer "*imap-debug*" | |
324 | ;; (erase-buffer)) | |
325 | (imap-mailbox-unselect) | |
326 | (imap-mailbox-select (imap-hash-mailbox iht)) | |
327 | ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state) | |
328 | ;; (setq imap-message-data (make-vector imap-message-prime 0) | |
329 | (imap-fetch-safe range | |
330 | (concat (format "(UID RFC822.SIZE BODY %s " | |
331 | (if headers-only "" "BODY.PEEK[TEXT]")) | |
0472835f | 332 | (format "BODY.PEEK[HEADER.FIELDS %s])" |
3d994264 | 333 | imap-hash-headers)))))) |
0472835f | 334 | |
3d994264 TZ |
335 | (provide 'imap-hash) |
336 | ;;; imap-hash.el ends here | |
337 | ||
338 | ;; ignore, for testing only | |
339 | ||
340 | ;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test")) | |
341 | ;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test")) | |
342 | ;;; (imap-hash-make "server1" "INBOX.mailbox2") | |
343 | ;;; (imap-hash-p iht) | |
344 | ;;; (imap-hash-get 35 iht) | |
345 | ;;; (imap-hash-get 38 iht) | |
346 | ;;; (imap-hash-get 37 iht t) | |
347 | ;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) | |
348 | ;;; (imap-hash-put (imap-hash-get 5 iht) iht) | |
349 | ;;; (with-current-buffer (imap-hash-get-buffer iht) (let ((uid (imap-hash-put (imap-hash-get 5 iht) iht))) (imap-hash-put uid iht uid))) | |
350 | ;;; (imap-hash-put (imap-hash-get 35 iht) iht) | |
351 | ;;; (imap-hash-make-message '((Subject . "normal")) "normal body") | |
352 | ;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new"))) | |
353 | ;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject))) | |
354 | ;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject))) | |
355 | ;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil) | |
356 | ;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht)) | |
357 | ;;; (kill-buffer (imap-hash-buffer-name iht)) | |
358 | ;;; (imap-hash-map 'debug iht) | |
359 | ;;; (imap-hash-map 'debug iht t) | |
360 | ;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") | |
361 | ;;;(imap-hash-count iht) | |
362 | ;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) | |
363 | ;;; (kill-buffer (imap-hash-buffer-name iht)) | |
364 | ;;; this should always return t if the server is up, automatically reopening if needed | |
365 | ;;; (imap-opened (imap-hash-get-buffer iht)) | |
366 | ;;; (imap-hash-buffer-name iht) | |
367 | ;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state)) | |
368 | ;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") | |
369 | ;;; (imap-hash-fetch iht nil) | |
370 | ;;; (imap-hash-fetch iht t) | |
371 | ;;; (imap-hash-fetch iht nil 1 2 3) | |
372 | ;;; (imap-hash-fetch iht t 1 2 3) | |
3999968a MB |
373 | |
374 | ;; arch-tag: 071410ac-91dc-4e36-b892-18e057d639c5 |