[PATCH 10/11] emacs: Add support for PGP/MIME verification/decryption
Jameson Graef Rollins
jrollins at finestructure.net
Wed May 25 18:01:19 PDT 2011
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 | 1 +
emacs/notmuch-crypto.el | 104 +++++++++++++++++++++++++++++++++++++++++++++++
emacs/notmuch-lib.el | 5 ++
emacs/notmuch-mua.el | 9 +++-
emacs/notmuch-query.el | 7 ++-
emacs/notmuch-show.el | 65 ++++++++++++++++++++---------
emacs/notmuch.el | 10 ++++-
7 files changed, 175 insertions(+), 26 deletions(-)
create mode 100644 emacs/notmuch-crypto.el
diff --git a/emacs/Makefile.local b/emacs/Makefile.local
index 1c09d87..1022777 100644
--- a/emacs/Makefile.local
+++ b/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 := \
diff --git a/emacs/notmuch-crypto.el b/emacs/notmuch-crypto.el
new file mode 100644
index 0000000..944452b
--- /dev/null
+++ b/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 at 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)
diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el
index cc80fb2..1ced0f1 100644
--- a/emacs/notmuch-lib.el
+++ b/emacs/notmuch-lib.el
@@ -156,5 +156,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)
diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el
index dc7b386..003b313 100644
--- a/emacs/notmuch-mua.el
+++ b/emacs/notmuch-mua.el
@@ -70,12 +70,17 @@ list."
notmuch-mua-hidden-headers))
(defun notmuch-mua-reply (query-string)
- (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
diff --git a/emacs/notmuch-query.el b/emacs/notmuch-query.el
index 921f624..d66baea 100644
--- a/emacs/notmuch-query.el
+++ b/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))
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 9a38d9c..e0cd41f 100644
--- a/emacs/notmuch-show.el
+++ b/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
diff --git a/emacs/notmuch.el b/emacs/notmuch.el
index 64f72a0..837136d 100644
--- a/emacs/notmuch.el
+++ b/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 ()
--
1.7.4.4
More information about the notmuch
mailing list