lisp/net/imap-hash.el

   1 ;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox
   2
   3 ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   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)
  70   "Make a new imap-hash object using SERVER, PORT, and MAILBOX.
  71 USER, PASSWORD and SSL are optional.
  72 The test is set to t, meaning all messages are considered."
  73   (when (and server port mailbox)
  74     (list :server server :port port :mailbox mailbox
  75           :ssl ssl :user user :password password
  76           :test t)))
  77
  78 (defun imap-hash-p (iht)
  79   "Check whether IHT is a valid imap-hash."
  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
  98 \(e.g. by `imap-hash-map'), or REFETCH to be t.
  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))
 109        (imap-hash-get-body
 110         (imap-hash-data-body details))))))
 111
 112 (defun imap-hash-put (value iht &optional key)
 113   "Put VALUE in the imap-hash IHT.  Return the new key.
 114 If KEY is given, removes it.
 115 VALUE can be a list of the headers (an alist, see `imap-hash-map')
 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
 124           (funcall 'imap-hash-make-message
 125                    (nth 0 value)
 126                    (nth 1 value)
 127                    nil)
 128           (setq newuid (nth 1 (imap-message-append
 129                                (imap-hash-mailbox iht)
 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',
 136 using `message-setup'.
 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
 157 been called and the imap-hash server buffer to be current,
 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)
 175     (mapcar (lambda (header)
 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
 202                                                ((stringp test)
 203                                                 (string-match
 204                                                  test
 205                                                  (format "%s" (aget hlist 'Subject))))
 206                                                ((functionp test)
 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)
 221   "Count the number of messages in the imap-hash IHT.
 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)
 229   "Return the test used by `imap-hash-map' for IHT.
 230 When the test is t, any key will be a candidate.
 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.
 234 The function is passed the message headers (see `imap-hash-get-headers')."
 235   (plist-get iht :test))
 236
 237 (defun imap-hash-server (iht)
 238   "Return the server used by the imap-hash IHT."
 239   (plist-get iht :server))
 240
 241 (defun imap-hash-port (iht)
 242   "Return the port used by the imap-hash IHT."
 243   (plist-get iht :port))
 244
 245 (defun imap-hash-ssl (iht)
 246   "Return the SSL need for the imap-hash IHT."
 247   (plist-get iht :ssl))
 248
 249 (defun imap-hash-mailbox (iht)
 250   "Return the mailbox used by the imap-hash IHT."
 251   (plist-get iht :mailbox))
 252
 253 (defun imap-hash-user (iht)
 254   "Return the username used by the imap-hash IHT."
 255   (plist-get iht :user))
 256
 257 (defun imap-hash-password (iht)
 258   "Return the password used by the imap-hash IHT."
 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))
 266          (auth-need (not (and (imap-hash-user iht)
 267                               (imap-hash-password iht))))
 268          ;; this will not be needed if auth-need is t
 269          (auth-info (when auth-need
 270                       (auth-source-user-or-password
 271                        '("login" "password")
 272                        server port)))
 273          (auth-user (or (imap-hash-user iht)
 274                         (nth 0 auth-info)))
 275          (auth-passwd (or (imap-hash-password iht)
 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))
 286                   (error "IMAP server does not support IMAP4r1, it won't work, sorry")
 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)
 317     (let ((range (if messages
 318                      (list
 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]"))
 332                                (format "BODY.PEEK[HEADER.FIELDS %s])"
 333                                      imap-hash-headers))))))
 334
 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)
 373
 374 ;; arch-tag: 071410ac-91dc-4e36-b892-18e057d639c5