view lisp/net/imap-hash.el @ 110410:f2e111723c3a

Merge changes made in Gnus trunk. Reimplement nnimap, and do tweaks to the rest of the code to support that. * gnus-int.el (gnus-finish-retrieve-group-infos) (gnus-retrieve-group-data-early): New functions. * gnus-range.el (gnus-range-nconcat): New function. * gnus-start.el (gnus-get-unread-articles): Support early retrieval of data. (gnus-read-active-for-groups): Support finishing the early retrieval of data. * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name if the move is internal, so that nnimap can do fast internal moves. * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for nnimap usage. * nnimap.el: Rewritten. * nnmail.el (nnmail-inhibit-default-split-group): New internal variable to allow the mail splitting to not return a default group. This is useful for nnimap, which will leave unmatched mail in the inbox. * utf7.el (utf7-encode): Autoload. Implement shell connection. * nnimap.el (nnimap-open-shell-stream): New function. (nnimap-open-connection): Use it. Get the number of lines by using BODYSTRUCTURE. (nnimap-transform-headers): Get the number of lines in each message. (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the number of lines. Not all servers return UIDNEXT. Work past this problem. Remove junk from end of file. Fix typo in "bogus" section. Make capabilties be case-insensitive. Require cl when compiling. Don't bug out if the LIST command doesn't have any parameters. 2010-09-17 Knut Anders Hatlen <[e-mail]> (tiny change) * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command doesn't have any parameters. (mm-text-html-renderer): Document gnus-article-html. 2010-09-17 Julien Danjou <[e-mail]> (tiny fix) * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. * dgnushack.el: Define netrc-credentials. If the user doesn't have a /etc/services, supply some sensible port defaults. Have `unseen-or-unread' select an unread unseen article first. (nntp-open-server): Return whether the open was successful or not. Throughout all files, replace (save-excursion (set-buffer ...)) with (with-current-buffer ... ). Save result so that it doesn't say "failed" all the time. Add ~/.authinfo to the default, since that's probably most useful for users. Don't use the "finish" method when we're reading from the agent. Add some more nnimap-relevant agent stuff to nnagent.el. * nnimap.el (nnimap-with-process-buffer): Removed. Revert one line that was changed by mistake in the last checkin. (nnimap-open-connection): Don't error out when we can't make a connection nnimap-related changes to avoid bugging out if we can't contact a server. * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups from methods that are denied. * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log in. (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for nothing. * gnus-sum.el (gnus-select-newsgroup): Indent.

;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox

;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.

;; Author: Teodor Zlatanov <[e-mail]>
;; Keywords: mail

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This module provides hashtable-like functions on top of imap.el
;; functionality.  All the authentication is handled by auth-source so
;; there are no authentication options here, only the server and
;; mailbox names are needed.

;; Create a IHT (imap-hash table) object with `imap-hash-make'.  Then
;; use it with `imap-hash-map' to map a function across all the
;; messages.  Use `imap-hash-get' and `imap-hash-rem' to operate on
;; individual messages.  See the tramp-imap.el library in Tramp if you
;; need to see practical examples.

;; This only works with IMAP4r1.  Sorry to everyone without it, but
;; the compatibility code is too annoying and it's 2009.

;; TODO: Use SEARCH instead of FETCH when a test is specified.  List
;; available mailboxes.  Don't select an invalid mailbox.

;;; Code:

(require 'assoc)
(require 'imap)
(require 'sendmail)			; for mail-header-separator
(require 'message)
(autoload 'auth-source-user-or-password "auth-source")

;; retrieve these headers
(defvar imap-hash-headers
  (append '(Subject From Date Message-Id References In-Reply-To Xref)))

;; from nnheader.el
(defsubst imap-hash-remove-cr-followed-by-lf ()
  (goto-char (point-max))
  (while (search-backward "\r\n" nil t)
    (delete-char 1)))

;; from nnheader.el
(defun imap-hash-ms-strip-cr (&optional string)
  "Strip ^M from the end of all lines in current buffer or STRING."
  (if string
    (with-temp-buffer
      (insert string)
      (imap-hash-remove-cr-followed-by-lf)
      (buffer-string))
    (save-excursion
      (imap-hash-remove-cr-followed-by-lf))))

(defun imap-hash-make (server port mailbox &optional user password ssl)
  "Make a new imap-hash object using SERVER, PORT, and MAILBOX.
USER, PASSWORD and SSL are optional.
The test is set to t, meaning all messages are considered."
  (when (and server port mailbox)
    (list :server server :port port :mailbox mailbox
	  :ssl ssl :user user :password password
	  :test t)))

(defun imap-hash-p (iht)
  "Check whether IHT is a valid imap-hash."
  (and
   (imap-hash-server iht)
   (imap-hash-port iht)
   (imap-hash-mailbox iht)
   (imap-hash-test iht)))

(defmacro imap-hash-gather (uid)
  `(imap-message-get ,uid 'BODYDETAIL))

(defmacro imap-hash-data-body (details)
  `(nth 2 (nth 1 ,details)))

(defmacro imap-hash-data-headers (details)
  `(nth 2 (nth 0 ,details)))

(defun imap-hash-get (key iht &optional refetch)
  "Get the value for KEY in the imap-hash IHT.
Requires either `imap-hash-fetch' to be called beforehand
\(e.g. by `imap-hash-map'), or REFETCH to be t.
Returns a list of the headers (an alist, see `imap-hash-map') and
the body of the message as a string.
Also see `imap-hash-test'."
  (with-current-buffer (imap-hash-get-buffer iht)
    (when refetch
      (imap-hash-fetch iht nil key))
  (let ((details (imap-hash-gather key)))
      (list
       (imap-hash-get-headers
	(imap-hash-data-headers details))
       (imap-hash-get-body
	(imap-hash-data-body details))))))

(defun imap-hash-put (value iht &optional key)
  "Put VALUE in the imap-hash IHT.  Return the new key.
If KEY is given, removes it.
VALUE can be a list of the headers (an alist, see `imap-hash-map')
and the body of the message as a string.  It can also be a uid,
in which case `imap-hash-get' will be called to get the value.
Also see `imap-hash-test'."
  (let ((server-buffer (imap-hash-get-buffer iht))
	(value (if (listp value) value (imap-hash-get value iht)))
	newuid)
      (when value
	(with-temp-buffer
	  (funcall 'imap-hash-make-message
		   (nth 0 value)
		   (nth 1 value)
		   nil)
	  (setq newuid (nth 1 (imap-message-append
			       (imap-hash-mailbox iht)
			       (current-buffer) nil nil server-buffer)))
	  (when key (imap-hash-rem key iht))))
      newuid))

(defun imap-hash-make-message (headers body &optional overrides)
  "Make a message with HEADERS and BODY suitable for `imap-append',
using `message-setup'.
Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'."
  ;; don't insert a signature no matter what
  (let (message-signature)
    (message-setup
     (append overrides headers))
    (message-generate-headers message-required-mail-headers)
    (message-remove-header "X-Draft-From")
    (message-goto-body)
    (insert (or (aget overrides 'body)
		body
		""))
    (goto-char (point-min))
    ;; TODO: make this search better
    (if (search-forward mail-header-separator nil t)
	(delete-region (line-beginning-position) (line-end-position))
      (error "Could not find the body separator in the encoded message!"))))

(defun imap-hash-rem (key iht)
  "Remove KEY in the imap-hash IHT.
Also see `imap-hash-test'.  Requires `imap-hash-fetch' to have
been called and the imap-hash server buffer to be current,
so it's best to use it inside `imap-hash-map'.
The key will not be found on the next `imap-hash-map' call."
  (with-current-buffer (imap-hash-get-buffer iht)
    (imap-message-flags-add
     (imap-range-to-message-set (list key))
     "\\Deleted" 'silent)
    (imap-mailbox-expunge t)))

(defun imap-hash-clear (iht)
  "Remove all keys in the imap-hash IHT.
Also see `imap-hash-test'."
  (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht))

(defun imap-hash-get-headers (text-headers)
  (with-temp-buffer
    (insert (or text-headers ""))
    (imap-hash-remove-cr-followed-by-lf)
    (mapcar (lambda (header)
	      (cons header
		    (message-fetch-field (format "%s" header))))
	    imap-hash-headers)))

(defun imap-hash-get-body (text)
  (with-temp-buffer
    (insert (or text ""))
    (imap-hash-remove-cr-followed-by-lf)
    (buffer-string)))

(defun imap-hash-map (function iht &optional headers-only &rest messages)
  "Call FUNCTION for all entries in IHT and pass it the message uid,
the headers (an alist, see `imap-hash-headers'), and the body
contents as a string.  If HEADERS-ONLY is not nil, the body will be nil.
Returns results of evaluating, as would `mapcar'.
If MESSAGES are given, iterate only over those UIDs.
Also see `imap-hash-test'."
  (imap-hash-fetch iht headers-only)
  (let ((test (imap-hash-test iht)))
    (with-current-buffer (imap-hash-get-buffer iht)
      (delq nil
	    (imap-message-map (lambda (message ignored-parameter)
				(let* ((details (imap-hash-gather message))
				       (headers (imap-hash-data-headers details))
				       (hlist (imap-hash-get-headers headers))
				       (runit (cond
					       ((stringp test)
						(string-match
						 test
						 (format "%s" (aget hlist 'Subject))))
					       ((functionp test)
						(funcall test hlist))
					       ;; otherwise, return test itself
					       (t test))))
				  ;;(debug message headers)
				  (when runit
				    (funcall function
					     message
					     (imap-hash-get-headers
					      headers)
					     (imap-hash-get-body
					      (imap-hash-data-body details))))))
			      "UID")))))

(defun imap-hash-count (iht)
  "Count the number of messages in the imap-hash IHT.
Also see `imap-hash-test'.  It uses `imap-hash-map' so just use that
function if you want to do more than count the elements."
  (length (imap-hash-map (lambda (a b c)) iht t)))

(defalias 'imap-hash-size 'imap-hash-count)

(defun imap-hash-test (iht)
  "Return the test used by `imap-hash-map' for IHT.
When the test is t, any key will be a candidate.
When the test is a string, messages will be filtered on that string as a
regexp against the subject.
When the test is a function, messages will be filtered with it.
The function is passed the message headers (see `imap-hash-get-headers')."
  (plist-get iht :test))

(defun imap-hash-server (iht)
  "Return the server used by the imap-hash IHT."
  (plist-get iht :server))

(defun imap-hash-port (iht)
  "Return the port used by the imap-hash IHT."
  (plist-get iht :port))

(defun imap-hash-ssl (iht)
  "Return the SSL need for the imap-hash IHT."
  (plist-get iht :ssl))

(defun imap-hash-mailbox (iht)
  "Return the mailbox used by the imap-hash IHT."
  (plist-get iht :mailbox))

(defun imap-hash-user (iht)
  "Return the username used by the imap-hash IHT."
  (plist-get iht :user))

(defun imap-hash-password (iht)
  "Return the password used by the imap-hash IHT."
  (plist-get iht :password))

(defun imap-hash-open-connection (iht)
  "Open the connection used for IMAP interactions with the imap-hash IHT."
  (let* ((server (imap-hash-server iht))
	 (port (imap-hash-port iht))
	 (ssl-need (imap-hash-ssl iht))
	 (auth-need (not (and (imap-hash-user iht)
			      (imap-hash-password iht))))
	 ;; this will not be needed if auth-need is t
	 (auth-info (when auth-need
		      (auth-source-user-or-password
		       '("login" "password")
		       server port)))
	 (auth-user (or (imap-hash-user iht)
			(nth 0 auth-info)))
	 (auth-passwd (or (imap-hash-password iht)
			  (nth 1 auth-info)))
	 (imap-logout-timeout nil))

	;; (debug "opening server: opened+state" (imap-opened) imap-state)
	;; this is the only place where IMAP vs IMAPS matters
	(if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer))
	    (progn
	      ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state)
	      ;; (debug "authenticating" auth-user auth-passwd)
	      (if (not (imap-capability 'IMAP4rev1))
		  (error "IMAP server does not support IMAP4r1, it won't work, sorry")
		(imap-authenticate auth-user auth-passwd)
		(imap-id)
		;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state)
		(imap-opened (current-buffer))))
	  (error "Could not open the IMAP buffer"))))

(defun imap-hash-get-buffer (iht)
  "Get or create the connection buffer to be used for the imap-hash IHT."
  (let* ((name (imap-hash-buffer-name iht))
	 (buffer (get-buffer name)))
  (if (and buffer (imap-opened buffer))
      buffer
    (when buffer (kill-buffer buffer))
    (with-current-buffer (get-buffer-create name)
      (setq buffer-undo-list t)
      (when (imap-hash-open-connection iht)
	(current-buffer))))))

(defun imap-hash-buffer-name (iht)
  "Get the connection buffer to be used for the imap-hash IHT."
  (when (imap-hash-p iht)
    (let ((server (imap-hash-server iht))
	  (port (imap-hash-port iht))
	  (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL")))
      (format "*imap-hash/%s:%s:%s*" server port ssl-text))))

(defun imap-hash-fetch (iht &optional headers-only &rest messages)
  "Fetch all the messages for imap-hash IHT.
Get only the headers if HEADERS-ONLY is not nil."
  (with-current-buffer (imap-hash-get-buffer iht)
    (let ((range (if messages
		     (list
		      (imap-range-to-message-set messages)
		      (imap-range-to-message-set messages))
		   '("1:*" . "1,*:*"))))

      ;; (with-current-buffer "*imap-debug*"
      ;;   (erase-buffer))
      (imap-mailbox-unselect)
      (imap-mailbox-select (imap-hash-mailbox iht))
      ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state)
	  ;; (setq imap-message-data (make-vector imap-message-prime 0)
      (imap-fetch-safe range
		       (concat (format "(UID RFC822.SIZE BODY %s "
				       (if headers-only "" "BODY.PEEK[TEXT]"))
			       (format "BODY.PEEK[HEADER.FIELDS %s])"
				     imap-hash-headers))))))

(provide 'imap-hash)
;;; imap-hash.el ends here

;; ignore, for testing only

;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test"))
;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test"))
;;; (imap-hash-make "server1" "INBOX.mailbox2")
;;; (imap-hash-p iht)
;;; (imap-hash-get 35 iht)
;;; (imap-hash-get 38 iht)
;;; (imap-hash-get 37 iht t)
;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*"))
;;; (imap-hash-put (imap-hash-get 5 iht) iht)
;;; (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)))
;;; (imap-hash-put (imap-hash-get 35 iht) iht)
;;; (imap-hash-make-message '((Subject . "normal")) "normal body")
;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new")))
;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject)))
;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject)))
;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil)
;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht))
;;; (kill-buffer (imap-hash-buffer-name iht))
;;; (imap-hash-map 'debug iht)
;;; (imap-hash-map 'debug iht t)
;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome")
;;;(imap-hash-count iht)
;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*"))
;;; (kill-buffer (imap-hash-buffer-name iht))
;;; this should always return t if the server is up, automatically reopening if needed
;;; (imap-opened (imap-hash-get-buffer iht))
;;; (imap-hash-buffer-name iht)
;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state))
;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome")
;;; (imap-hash-fetch iht nil)
;;; (imap-hash-fetch iht t)
;;; (imap-hash-fetch iht nil 1 2 3)
;;; (imap-hash-fetch iht t 1 2 3)

;; arch-tag: 071410ac-91dc-4e36-b892-18e057d639c5