[PATCH v6] emacs: Use the new JSON reply format and message-cite-original

[Austin Clements]

Quoth Adam Wolfe Gordon on Feb 21 at 11:46 pm:
> Use the new JSON reply format to create replies in emacs. Quote HTML
> parts nicely by using mm-display-part to turn them into displayable
> text, then quoting them with message-cite-original. This is very
> useful for users who regularly receive HTML-only email.
> 
> Use message-mode's message-cite-original function to create the
> quoted body for reply messages. In order to make this act like the
> existing notmuch defaults, you will need to set the following in
> your emacs configuration:
> 
> message-citation-line-format "On %a, %d %b %Y, %f wrote:"
> message-citation-line-function 'message-insert-formatted-citation-line
> 
> The tests have been updated to reflect the (ugly) emacs default.
> ---
>  emacs/notmuch-lib.el |   11 ++++
>  emacs/notmuch-mua.el |  136 ++++++++++++++++++++++++++++++++++---------------
>  test/emacs           |    8 ++--
>  3 files changed, 109 insertions(+), 46 deletions(-)
> 
> diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el
> index 7e3f110..8bac596 100644
> --- a/emacs/notmuch-lib.el
> +++ b/emacs/notmuch-lib.el
> @@ -206,6 +206,17 @@ 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))
> +
> +(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 4be7c13..5adf4d8 100644
> --- a/emacs/notmuch-mua.el
> +++ b/emacs/notmuch-mua.el
> @@ -19,11 +19,15 @@
>  ;;
>  ;; Authors: David Edmondson <dme at 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,56 +76,104 @@ list."
>  	    (push header message-hidden-headers)))
>  	notmuch-mua-hidden-headers))
>  
> +(defun notmuch-mua-get-displayed-part (part query-string)
> +  (with-temp-buffer
> +    (if (plist-get part :content)
> +	(insert (plist-get part :content))
> +      (call-process notmuch-command nil t nil "show" "--format=raw"
> +		    (format "--part=%s" (plist-get part :id))
> +		    query-string))
> +
> +    (let ((handle (mm-make-handle (current-buffer) (list (plist-get part :content-type))))
> +	  (end-of-orig (point-max)))
> +      (mm-display-part handle)
> +      (delete-region (point-min) end-of-orig)
> +      (buffer-substring (point-min) (point-max)))))

Even if it's not possible to completely reuse the show mechanisms
here, it would be nice to reuse the easy ones.  In particular,
notmuch-show-get-bodypart-content looks like it could easily be lifted
to the lib with the addition of a process-crypto argument.  It would
be slightly less efficient, but even now there's some important logic
in notmuch-show-get-bodypart-content that's missing here regarding
encoding handling.

> +
> +(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"))
> +	(json-object-type 'plist)
> +	(json-array-type 'list)
> +	(json-false 'nil)

These should be bound just around the setq reply below since they're
global controls (I highly doubt anything else this function calls
would invoke the JSON parser, but we shouldn't tempt dynamic scoping).

> +	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)
> -      (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)
> +      (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)
> -
> +	(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-mua-get-displayed-part part query-string)))
> +		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)))))

Since the goto-char is really about setting up point for the push-mark
below, it probably makes sense to lift it out of the let and put it
immediately before the push-mark.  I spent a while trying to figure
out what it had to do with the message-cite-original before realizing
that it really had to do with what followed the let.

> +
> +  (push-mark)
>    (message-goto-body)
> -  ;; Original message may contain (malicious) MML tags.  We must
> -  ;; properly quote them in the reply.  Note that using `point-max'
> -  ;; instead of `mark' here is wrong.  The buffer may include user's
> -  ;; signature which should not be MML-quoted.
> -  (mml-quote-region (point) (mark)))
> +  (set-buffer-modified-p nil))
>  
>  (defun notmuch-mua-forward-message ()
>    (message-forward)
> @@ -147,7 +199,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))
>  
> @@ -210,7 +262,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/test/emacs b/test/emacs
> index c3a75e9..a6786d4 100755
> --- a/test/emacs
> +++ b/test/emacs
> @@ -268,13 +268,13 @@ Subject: Re: Testing message sent via SMTP
>  In-Reply-To: <XXX>
>  Fcc: $(pwd)/mail/sent
>  --text follows this line--
> -On 01 Jan 2000 12:00:00 -0000, Notmuch Test Suite <test_suite at notmuchmail.org> wrote:
> +Notmuch Test Suite <test_suite at 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 at 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 at 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 at message.id>
>  Fcc: ${MAIL_DIR}/sent
>  --text follows this line--
> -On Fri, 05 Jan 2001 15:43:57 +0000, Notmuch Test Suite <test_suite at notmuchmail.org> wrote:
> +Notmuch Test Suite <test_suite at notmuchmail.org> writes:
> +
>  > <#!part disposition=inline>
>  EOF
>  test_expect_equal_file OUTPUT EXPECTED