diff options
| -rw-r--r-- | emacs/notmuch-lib.el | 30 | ||||
| -rw-r--r-- | emacs/notmuch-mua.el | 124 | ||||
| -rw-r--r-- | emacs/notmuch-show.el | 31 | ||||
| -rwxr-xr-x | test/emacs | 8 |
4 files changed, 123 insertions, 70 deletions
diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el index 7e3f1109..c146748a 100644 --- a/emacs/notmuch-lib.el +++ b/emacs/notmuch-lib.el @@ -206,6 +206,36 @@ the user hasn't set this variable with the old or new value." (setq seq (nconc (delete elem seq) (list elem)))))) seq)) +(defun notmuch-parts-filter-by-type (parts type) + "Given a list of message parts, return a list containing the ones matching +the given type." + (remove-if-not + (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type)) + parts)) + +;; Helper for parts which are generally not included in the default +;; JSON output. +(defun notmuch-get-bodypart-internal (message-id part-number process-crypto) + (let ((args '("show" "--format=raw")) + (part-arg (format "--part=%s" part-number))) + (setq args (append args (list part-arg))) + (if process-crypto + (setq args (append args '("--decrypt")))) + (setq args (append args (list message-id))) + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (progn + (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) + (buffer-string)))))) + +(defun notmuch-get-bodypart-content (msg part nth process-crypto) + (or (plist-get part :content) + (notmuch-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth process-crypto))) + +(defun notmuch-plist-to-alist (plist) + (loop for (key value . rest) on plist by #'cddr + collect (cons (substring (symbol-name key) 1) value))) + ;; Compatibility functions for versions of emacs before emacs 23. ;; ;; Both functions here were copied from emacs 23 with the following copyright: diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el index 13244eb8..6aae3a05 100644 --- a/emacs/notmuch-mua.el +++ b/emacs/notmuch-mua.el @@ -19,11 +19,15 @@ ;; ;; Authors: David Edmondson <dme@dme.org> +(require 'json) (require 'message) +(require 'format-spec) (require 'notmuch-lib) (require 'notmuch-address) +(eval-when-compile (require 'cl)) + ;; (defcustom notmuch-mua-send-hook '(notmuch-mua-message-send-hook) @@ -72,54 +76,92 @@ list." (push header message-hidden-headers))) notmuch-mua-hidden-headers)) +(defun notmuch-mua-get-quotable-parts (parts) + (loop for part in parts + if (notmuch-match-content-type (plist-get part :content-type) "multipart/alternative") + collect (let* ((subparts (plist-get part :content)) + (types (mapcar (lambda (part) (plist-get part :content-type)) subparts)) + (chosen-type (car (notmuch-multipart/alternative-choose types)))) + (loop for part in (reverse subparts) + if (notmuch-match-content-type (plist-get part :content-type) chosen-type) + return part)) + else if (notmuch-match-content-type (plist-get part :content-type) "multipart/*") + append (notmuch-mua-get-quotable-parts (plist-get part :content)) + else if (notmuch-match-content-type (plist-get part :content-type) "text/*") + collect part)) + (defun notmuch-mua-reply (query-string &optional sender reply-all) - (let (headers - body - (args '("reply"))) - (if notmuch-show-process-crypto - (setq args (append args '("--decrypt")))) + (let ((args '("reply" "--format=json")) + reply + original) + (when notmuch-show-process-crypto + (setq args (append args '("--decrypt")))) + (if reply-all (setq args (append args '("--reply-to=all"))) (setq args (append args '("--reply-to=sender")))) (setq args (append args (list query-string))) - ;; This make assumptions about the output of `notmuch reply', but - ;; really only that the headers come first followed by a blank - ;; line and then the body. + + ;; Get the reply object as JSON, and parse it into an elisp object. (with-temp-buffer (apply 'call-process (append (list notmuch-command nil (list t t) nil) args)) (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (save-excursion - (save-restriction - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (setq headers (mail-header-extract))))) - (forward-line 1) - ;; Original message may contain (malicious) MML tags. We must - ;; properly quote them in the reply. - (mml-quote-region (point) (point-max)) - (setq body (buffer-substring (point) (point-max)))) - ;; If sender is non-nil, set the From: header to its value. - (when sender - (mail-header-set 'from sender headers)) - (let - ;; Overlay the composition window on that being used to read - ;; the original message. - ((same-window-regexps '("\\*mail .*"))) - (notmuch-mua-mail (mail-header 'to headers) - (mail-header 'subject headers) - (message-headers-to-generate headers t '(to subject)))) - ;; insert the message body - but put it in front of the signature - ;; if one is present - (goto-char (point-max)) - (if (re-search-backward message-signature-separator nil t) + (let ((json-object-type 'plist) + (json-array-type 'list) + (json-false 'nil)) + (setq reply (json-read)))) + + ;; Extract the original message to simplify the following code. + (setq original (plist-get reply :original)) + + ;; Extract the headers of both the reply and the original message. + (let* ((original-headers (plist-get original :headers)) + (reply-headers (plist-get reply :reply-headers))) + + ;; If sender is non-nil, set the From: header to its value. + (when sender + (plist-put reply-headers :From sender)) + (let + ;; Overlay the composition window on that being used to read + ;; the original message. + ((same-window-regexps '("\\*mail .*"))) + (notmuch-mua-mail (plist-get reply-headers :To) + (plist-get reply-headers :Subject) + (notmuch-plist-to-alist reply-headers))) + ;; Insert the message body - but put it in front of the signature + ;; if one is present + (goto-char (point-max)) + (if (re-search-backward message-signature-separator nil t) (forward-line -1) - (goto-char (point-max))) - (insert body) - (push-mark)) - (set-buffer-modified-p nil) - - (message-goto-body)) + (goto-char (point-max))) + + (let ((from (plist-get original-headers :From)) + (date (plist-get original-headers :Date)) + (start (point))) + + ;; message-cite-original constructs a citation line based on the From and Date + ;; headers of the original message, which are assumed to be in the buffer. + (insert "From: " from "\n") + (insert "Date: " date "\n\n") + + ;; Get the parts of the original message that should be quoted; this includes + ;; all the text parts, except the non-preferred ones in a multipart/alternative. + (let ((quotable-parts (notmuch-mua-get-quotable-parts (plist-get original :body)))) + (mapc (lambda (part) + (insert (notmuch-get-bodypart-content original part + (plist-get part :id) + notmuch-show-process-crypto))) + quotable-parts)) + + (set-mark (point)) + (goto-char start) + ;; Quote the original message according to the user's configured style. + (message-cite-original)))) + + (goto-char (point-max)) + (push-mark) + (message-goto-body) + (set-buffer-modified-p nil)) (defun notmuch-mua-forward-message () (message-forward) @@ -145,7 +187,7 @@ OTHER-ARGS are passed through to `message-mail'." (when (not (string= "" user-agent)) (push (cons "User-Agent" user-agent) other-headers)))) - (unless (mail-header 'from other-headers) + (unless (mail-header 'From other-headers) (push (cons "From" (concat (notmuch-user-name) " <" (notmuch-user-primary-email) ">")) other-headers)) @@ -208,7 +250,7 @@ the From: address first." (interactive "P") (let ((other-headers (when (or prompt-for-sender notmuch-always-prompt-for-sender) - (list (cons 'from (notmuch-mua-prompt-for-sender)))))) + (list (cons 'From (notmuch-mua-prompt-for-sender)))))) (notmuch-mua-mail nil nil other-headers))) (defun notmuch-mua-new-forward-message (&optional prompt-for-sender) diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index ed938bf2..0cd7d826 100644 --- a/emacs/notmuch-show.el +++ b/emacs/notmuch-show.el @@ -488,7 +488,7 @@ message at DEPTH in the current thread." (setq notmuch-show-process-crypto ,process-crypto) ;; Always acquires the part via `notmuch part', even if it is ;; available in the JSON output. - (insert (notmuch-show-get-bodypart-internal ,message-id ,nth)) + (insert (notmuch-get-bodypart-internal ,message-id ,nth notmuch-show-process-crypto)) ,@body)))) (defun notmuch-show-save-part (message-id nth &optional filename content-type) @@ -536,7 +536,7 @@ current buffer, if possible." ;; test whether we are able to inline it (which includes both ;; capability and suitability tests). (when (mm-inlined-p handle) - (insert (notmuch-show-get-bodypart-content msg part nth)) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) (when (mm-inlinable-p handle) (set-buffer display-buffer) (mm-display-part handle) @@ -613,8 +613,8 @@ current buffer, if possible." ;; times (hundreds!), which results in many calls to ;; `notmuch part'. (unless content - (setq content (notmuch-show-get-bodypart-internal (concat "id:" message-id) - part-number)) + (setq content (notmuch-get-bodypart-internal (concat "id:" message-id) + part-number notmuch-show-process-crypto)) (with-current-buffer w3m-current-buffer (notmuch-show-w3m-cid-store-internal url message-id @@ -734,7 +734,7 @@ current buffer, if possible." ;; insert a header to make this clear. (if (> nth 1) (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))) - (insert (notmuch-show-get-bodypart-content msg part nth)) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) (save-excursion (save-restriction (narrow-to-region start (point-max)) @@ -744,7 +744,7 @@ current buffer, if possible." (defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth declared-type) (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)) (insert (with-temp-buffer - (insert (notmuch-show-get-bodypart-content msg part nth)) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) (goto-char (point-min)) (let ((file (make-temp-file "notmuch-ical")) result) @@ -806,25 +806,6 @@ current buffer, if possible." (intern (concat "notmuch-show-insert-part-" content-type)))) result)) -;; Helper for parts which are generally not included in the default -;; JSON output. -(defun notmuch-show-get-bodypart-internal (message-id part-number) - (let ((args '("show" "--format=raw")) - (part-arg (format "--part=%s" part-number))) - (setq args (append args (list part-arg))) - (if notmuch-show-process-crypto - (setq args (append args '("--decrypt")))) - (setq args (append args (list message-id))) - (with-temp-buffer - (let ((coding-system-for-read 'no-conversion)) - (progn - (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) - (buffer-string)))))) - -(defun notmuch-show-get-bodypart-content (msg part nth) - (or (plist-get part :content) - (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth))) - ;; (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type) @@ -268,13 +268,13 @@ Subject: Re: Testing message sent via SMTP In-Reply-To: <XXX> Fcc: ${MAIL_DIR}/sent --text follows this line-- -On 01 Jan 2000 12:00:00 -0000, Notmuch Test Suite <test_suite@notmuchmail.org> wrote: +Notmuch Test Suite <test_suite@notmuchmail.org> writes: + > This is a test that messages are sent via SMTP EOF test_expect_equal_file OUTPUT EXPECTED test_begin_subtest "Reply within emacs to a multipart/mixed message" -test_subtest_known_broken test_emacs '(notmuch-show "id:20091118002059.067214ed@hikari") (notmuch-show-reply) (test-output)' @@ -334,7 +334,6 @@ EOF test_expect_equal_file OUTPUT EXPECTED test_begin_subtest "Reply within emacs to a multipart/alternative message" -test_subtest_known_broken test_emacs '(notmuch-show "id:cf0c4d610911171136h1713aa59w9cf9aa31f052ad0a@mail.gmail.com") (notmuch-show-reply) (test-output)' @@ -385,7 +384,8 @@ Subject: Re: Quote MML tags in reply In-Reply-To: <test-emacs-mml-quoting@message.id> Fcc: ${MAIL_DIR}/sent --text follows this line-- -On Fri, 05 Jan 2001 15:43:57 +0000, Notmuch Test Suite <test_suite@notmuchmail.org> wrote: +Notmuch Test Suite <test_suite@notmuchmail.org> writes: + > <#!part disposition=inline> EOF test_expect_equal_file OUTPUT EXPECTED |