From 45fe3547458e0c403f7501bad89860afe2fa534a Mon Sep 17 00:00:00 2001 From: Jameson Graef Rollins Date: Wed, 25 May 2011 18:01:19 -0700 Subject: [PATCH] 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 | 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 1c09d87a..10227777 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 00000000..944452b9 --- /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 . +;; +;; Authors: Jameson Rollins + +(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 d5ca0f40..a21dc145 100644 --- a/emacs/notmuch-lib.el +++ b/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) diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el index 61a723b7..7c05a81f 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 &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 diff --git a/emacs/notmuch-query.el b/emacs/notmuch-query.el index 921f6246..d66baeab 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 2ba151ed..2f6be597 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 c22add7a..3311fe8b 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 (&optional prompt-for-sender) -- 2.26.2