emacs: Add support for PGP/MIME verification/decryption

A new emacs configuration variable "notmuch-crypto-process-mime"
controls the processing of PGP/MIME signatures and encrypted parts.
When this is set true, notmuch-query will use the notmuch show
--decrypt flag to decrypt encrypted messages and/or calculate the
sigstatus of signed messages.  If sigstatus is available, notmuch-show
will place a specially color-coded header at the begining of the
signed message.

Also included is the ability to switch decryption/verification on/off
on the fly, which is bound to M-RET in notmuch-search-mode.

emacs/Makefile.local

@@ -12,6 +12,7 @@ emacs_sources := \
 	$(dir)/notmuch-address.el \
 	$(dir)/notmuch-maildir-fcc.el \
 	$(dir)/notmuch-message.el \
+	$(dir)/notmuch-crypto.el \
 	$(dir)/coolj.el
 
 emacs_images := \

emacs/notmuch-crypto.el

@@ -0,0 +1,104 @@
+;; notmuch-crypto.el --- functions for handling display of cryptographic metadata.
+;;
+;; Copyright © Jameson Rollins
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch 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.
+;;
+;; Notmuch 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 Notmuch.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Jameson Rollins <jrollins@finestructure.net>
+
+(defcustom notmuch-crypto-process-mime nil
+  "Should cryptographic MIME parts be processed?
+
+If this variable is non-nil signatures in multipart/signed
+messages will be verified and multipart/encrypted parts will be
+decrypted.  The result of the crypto operation will be displayed
+in a specially colored header button at the top of the processed
+part.  Signed parts will have variously colored headers depending
+on the success or failure of the verification process and on the
+validity of user ID of the signer.
+
+The effect of setting this variable can be seen temporarily by
+viewing a signed or encrypted message with M-RET in notmuch
+search."
+  :group 'notmuch
+  :type 'boolean)
+
+(define-button-type 'notmuch-crypto-status-button-type
+  'action '(lambda (button) (message (button-get button 'help-echo)))
+  'follow-link t
+  'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."
+  'face '(:foreground "blue")
+  'mouse-face '(:foreground "blue"))
+
+(defun notmuch-crypto-insert-sigstatus-button (sigstatus from)
+  (let* ((status (plist-get sigstatus :status))
+	 (help-msg nil)
+	 (label "multipart/signed: signature not processed")
+	 (face '(:background "red" :foreground "black")))
+    (cond
+     ((string= status "good")
+      ; if userid present, userid has full or greater validity
+      (if (plist-member sigstatus :userid)
+	  (let ((userid (plist-get sigstatus :userid)))
+	    (setq label (concat "Good signature by: " userid))
+	    (setq face '(:background "green" :foreground "black")))
+	(let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint))))
+	  (setq label (concat "Good signature by key: " fingerprint))
+	  (setq face '(:background "orange" :foreground "black")))))
+     ((string= status "error")
+      (let ((keyid (concat "0x" (plist-get sigstatus :keyid))))
+	(setq label (concat "Unknown key ID " keyid " or unsupported algorithm"))
+	(setq face '(:background "red" :foreground "black"))))
+     ((string= status "bad")
+      (let ((keyid (concat "0x" (plist-get sigstatus :keyid))))
+	(setq label (concat "Bad signature (claimed key ID " keyid ")"))
+	(setq face '(:background "red" :foreground "black"))))
+     (t
+      (setq label "Unknown signature status")
+      (if status (setq label (concat label " \"" status "\"")))))
+    (insert-button
+     (concat "[ " label " ]")
+     :type 'notmuch-crypto-status-button-type
+     'help-echo help-msg
+     'face face
+     'mouse-face face
+     :notmuch-sigstatus sigstatus
+     :notmuch-from from)
+    (insert "\n")))
+
+(defun notmuch-crypto-insert-encstatus-button (encstatus)
+  (let* ((status (plist-get encstatus :status))
+	 (help-msg nil)
+	 (label "multipart/encrypted: decryption not attempted")
+	 (face '(:background "purple" :foreground "black")))
+    (cond
+     ((string= status "good")
+      (setq label "decryption successful"))
+     ((string= status "bad")
+      (setq label "decryption error"))
+     (t
+      (setq label (concat "unknown encstatus \"" status "\""))))
+    (insert-button
+     (concat "[ multipart/encrypted: " label " ]")
+     :type 'notmuch-crypto-status-button-type
+     'help-echo help-msg
+     'face face
+     'mouse-face face)
+    (insert "\n")))
+
+;;
+
+(provide 'notmuch-crypto)

emacs/notmuch-lib.el

@@ -165,5 +165,10 @@ was called."
    "Return non-nil if OBJECT is a mouse click event."
    (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))))
 
+;; This variable is used only buffer local, but it needs to be
+;; declared globally first to avoid compiler warnings.
+(defvar notmuch-show-process-crypto nil)
+(make-variable-buffer-local 'notmuch-show-process-crypto)
+
 (provide 'notmuch-lib)
 

emacs/notmuch-mua.el

@@ -70,12 +70,17 @@ list."
 	notmuch-mua-hidden-headers))
 
 (defun notmuch-mua-reply (query-string &optional sender)
-  (let (headers body)
+  (let (headers
+	body
+	(args '("reply")))
+    (if notmuch-show-process-crypto
+	(setq args (append args '("--decrypt"))))
+    (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.
     (with-temp-buffer
-      (call-process notmuch-command nil t nil "reply" query-string)
+      (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

emacs/notmuch-query.el

@@ -22,17 +22,20 @@
 (require 'notmuch-lib)
 (require 'json)
 
-(defun notmuch-query-get-threads (search-terms &rest options)
+(defun notmuch-query-get-threads (search-terms)
   "Return a list of threads of messages matching SEARCH-TERMS.
 
 A thread is a forest or list of trees. A tree is a two element
 list where the first element is a message, and the second element
 is a possibly empty forest of replies.
 "
-  (let  ((args (append '("show" "--format=json") search-terms))
+  (let  ((args '("show" "--format=json"))
 	 (json-object-type 'plist)
 	 (json-array-type 'list)
 	 (json-false 'nil))
+    (if notmuch-show-process-crypto
+	(setq args (append args '("--decrypt"))))
+    (setq args (append args search-terms))
     (with-temp-buffer
       (progn
 	(apply 'call-process (append (list notmuch-command nil (list t nil) nil) args))

emacs/notmuch-show.el

@@ -32,6 +32,7 @@
 (require 'notmuch-query)
 (require 'notmuch-wash)
 (require 'notmuch-mua)
+(require 'notmuch-crypto)
 
 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
 (declare-function notmuch-fontify-headers "notmuch" nil)
@@ -295,18 +296,20 @@ message at DEPTH in the current thread."
 ;; Functions handling particular MIME parts.
 
 (defun notmuch-show-save-part (message-id nth &optional filename)
-  (with-temp-buffer
-    ;; 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))
-    (let ((file (read-file-name
-		 "Filename to save as: "
-		 (or mailcap-download-directory "~/")
-		 nil nil
-		 filename))
-	  (require-final-newline nil)
-          (coding-system-for-write 'no-conversion))
-      (write-region (point-min) (point-max) file))))
+  (let ((process-crypto notmuch-show-process-crypto))
+    (with-temp-buffer
+      (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))
+      (let ((file (read-file-name
+		   "Filename to save as: "
+		   (or mailcap-download-directory "~/")
+		   nil nil
+		   filename))
+	    (require-final-newline nil)
+	    (coding-system-for-write 'no-conversion))
+	(write-region (point-min) (point-max) file)))))
 
 (defun notmuch-show-mm-display-part-inline (msg part content-type content)
   "Use the mm-decode/mm-view functions to display a part in the
@@ -551,13 +554,20 @@ current buffer, if possible."
 
 ;; Helper for parts which are generally not included in the default
 ;; JSON output.
-
+;; Uses the buffer-local variable notmuch-show-process-crypto to
+;; determine if parts should be decrypted first.
 (defun notmuch-show-get-bodypart-internal (message-id part-number)
-  (with-temp-buffer
-    (let ((coding-system-for-read 'no-conversion))
-      (call-process notmuch-command nil t nil
-		    "show" "--format=raw" (format "--part=%s" part-number) message-id)
-      (buffer-string))))
+  (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)
@@ -578,6 +588,16 @@ current buffer, if possible."
   "Insert the body part PART at depth DEPTH in the current thread."
   (let ((content-type (downcase (plist-get part :content-type)))
 	(nth (plist-get part :id)))
+    ;; add encryption status button if encstatus specified
+    (if (plist-member part :encstatus)
+	(let* ((encstatus (car (plist-get part :encstatus))))
+	  (notmuch-crypto-insert-encstatus-button encstatus)))
+    ;; add signature status button if sigstatus specified
+    (if (plist-member part :sigstatus)
+	(let* ((headers (plist-get msg :headers))
+	       (from (plist-get headers :From))
+	       (sigstatus (car (plist-get part :sigstatus))))
+	  (notmuch-crypto-insert-sigstatus-button sigstatus from)))
     (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
   ;; Some of the body part handlers leave point somewhere up in the
   ;; part, so we make sure that we're down at the end.
@@ -711,9 +731,10 @@ current buffer, if possible."
   (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
 
 (defvar notmuch-show-parent-buffer nil)
+(make-variable-buffer-local 'notmuch-show-parent-buffer)
 
 ;;;###autoload
-(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)
+(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name crypto-switch)
   "Run \"notmuch show\" with the given thread ID and display results.
 
 The optional PARENT-BUFFER is the notmuch-search buffer from
@@ -733,10 +754,14 @@ function is used. "
   (let ((buffer (get-buffer-create (generate-new-buffer-name
 				    (or buffer-name
 					(concat "*notmuch-" thread-id "*")))))
+	(process-crypto (if crypto-switch
+			    (not notmuch-crypto-process-mime)
+			  notmuch-crypto-process-mime))
 	(inhibit-read-only t))
     (switch-to-buffer buffer)
     (notmuch-show-mode)
-    (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)
+    (setq notmuch-show-parent-buffer parent-buffer)
+    (setq notmuch-show-process-crypto process-crypto)
     (erase-buffer)
     (goto-char (point-min))
     (save-excursion

emacs/notmuch.el

@@ -218,6 +218,7 @@ For a mouse binding, return nil."
     (define-key map "-" 'notmuch-search-remove-tag)
     (define-key map "+" 'notmuch-search-add-tag)
     (define-key map (kbd "RET") 'notmuch-search-show-thread)
+    (define-key map (kbd "M-RET") 'notmuch-search-show-thread-crypto-switch)
     map)
   "Keymap for \"notmuch search\" buffers.")
 (fset 'notmuch-search-mode-map notmuch-search-mode-map)
@@ -417,7 +418,11 @@ Complete list of currently available key bindings:
   "Return a list of authors for the current region"
   (notmuch-search-properties-in-region 'notmuch-search-subject beg end))
 
-(defun notmuch-search-show-thread ()
+(defun notmuch-search-show-thread-crypto-switch ()
+  (interactive)
+  (notmuch-search-show-thread t))
+
+(defun notmuch-search-show-thread (&optional crypto-switch)
   "Display the currently selected thread."
   (interactive)
   (let ((thread-id (notmuch-search-find-thread-id))
@@ -433,7 +438,8 @@ Complete list of currently available key bindings:
 			 (concat "*"
 				 (truncate-string-to-width subject 32 nil nil t)
 				 "*")
-			 32 nil nil t)))
+			 32 nil nil t))
+		      crypto-switch)
       (error "End of search results"))))
 
 (defun notmuch-search-reply-to-thread (&optional prompt-for-sender)