48/160ee4463f7cdeaa469eca3da083a629fce56f

   1 Return-Path: <jrollins@servo.finestructure.net>\r
   2 X-Original-To: notmuch@notmuchmail.org\r
   3 Delivered-To: notmuch@notmuchmail.org\r
   4 Received: from localhost (localhost [127.0.0.1])\r
   5         by olra.theworths.org (Postfix) with ESMTP id 64DFD421173\r
   6         for <notmuch@notmuchmail.org>; Wed, 25 May 2011 18:01:51 -0700 (PDT)\r
   7 X-Virus-Scanned: Debian amavisd-new at olra.theworths.org\r
   8 X-Spam-Flag: NO\r
   9 X-Spam-Score: -1.921\r
  10 X-Spam-Level: \r
  11 X-Spam-Status: No, score=-1.921 tagged_above=-999 required=5\r
  12         tests=[NO_DNS_FOR_FROM=0.379, RCVD_IN_DNSWL_MED=-2.3]\r
  13         autolearn=disabled\r
  14 Received: from olra.theworths.org ([127.0.0.1])\r
  15         by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024)\r
  16         with ESMTP id uABwAM6WlIrA for <notmuch@notmuchmail.org>;\r
  17         Wed, 25 May 2011 18:01:46 -0700 (PDT)\r
  18 Received: from outgoing-mail.its.caltech.edu (outgoing-mail.its.caltech.edu\r
  19         [131.215.239.19])\r
  20         by olra.theworths.org (Postfix) with ESMTP id 6799E429E32\r
  21         for <notmuch@notmuchmail.org>; Wed, 25 May 2011 18:01:37 -0700 (PDT)\r
  22 Received: from earth-doxen.imss.caltech.edu (localhost [127.0.0.1])\r
  23         by earth-doxen-postvirus (Postfix) with ESMTP id F097166E04A3;\r
  24         Wed, 25 May 2011 18:01:35 -0700 (PDT)\r
  25 X-Spam-Scanned: at Caltech-IMSS on earth-doxen by amavisd-new\r
  26 Received: from servo.finestructure.net (gwave-104.ligo.caltech.edu\r
  27         [131.215.114.104]) (Authenticated sender: jrollins)\r
  28         by earth-doxen-submit (Postfix) with ESMTP id BC51266E04AE;\r
  29         Wed, 25 May 2011 18:01:27 -0700 (PDT)\r
  30 Received: by servo.finestructure.net (Postfix, from userid 1000)\r
  31         id 8610D7CD; Wed, 25 May 2011 18:01:26 -0700 (PDT)\r
  32 From: Jameson Graef Rollins <jrollins@finestructure.net>\r
  33 To: notmuch@notmuchmail.org\r
  34 Subject: [PATCH 10/11] emacs: Add support for PGP/MIME verification/decryption\r
  35 Date: Wed, 25 May 2011 18:01:19 -0700\r
  36 Message-Id: <1306371680-19441-11-git-send-email-jrollins@finestructure.net>\r
  37 X-Mailer: git-send-email 1.7.4.4\r
  38 In-Reply-To: <1306371680-19441-1-git-send-email-jrollins@finestructure.net>\r
  39 References: <1306371680-19441-1-git-send-email-jrollins@finestructure.net>\r
  40 MIME-Version: 1.0\r
  41 Content-Type: text/plain; charset=UTF-8\r
  42 Content-Transfer-Encoding: 8bit\r
  43 X-BeenThere: notmuch@notmuchmail.org\r
  44 X-Mailman-Version: 2.1.13\r
  45 Precedence: list\r
  46 List-Id: "Use and development of the notmuch mail system."\r
  47         <notmuch.notmuchmail.org>\r
  48 List-Unsubscribe: <http://notmuchmail.org/mailman/options/notmuch>,\r
  49         <mailto:notmuch-request@notmuchmail.org?subject=unsubscribe>\r
  50 List-Archive: <http://notmuchmail.org/pipermail/notmuch>\r
  51 List-Post: <mailto:notmuch@notmuchmail.org>\r
  52 List-Help: <mailto:notmuch-request@notmuchmail.org?subject=help>\r
  53 List-Subscribe: <http://notmuchmail.org/mailman/listinfo/notmuch>,\r
  54         <mailto:notmuch-request@notmuchmail.org?subject=subscribe>\r
  55 X-List-Received-Date: Thu, 26 May 2011 01:01:52 -0000\r
  56 \r
  57 A new emacs configuration variable "notmuch-crypto-process-mime"\r
  58 controls the processing of PGP/MIME signatures and encrypted parts.\r
  59 When this is set true, notmuch-query will use the notmuch show\r
  60 --decrypt flag to decrypt encrypted messages and/or calculate the\r
  61 sigstatus of signed messages.  If sigstatus is available, notmuch-show\r
  62 will place a specially color-coded header at the begining of the\r
  63 signed message.\r
  64 \r
  65 Also included is the ability to switch decryption/verification on/off\r
  66 on the fly, which is bound to M-RET in notmuch-search-mode.\r
  67 ---\r
  68  emacs/Makefile.local    |    1 +\r
  69  emacs/notmuch-crypto.el |  104 +++++++++++++++++++++++++++++++++++++++++++++++\r
  70  emacs/notmuch-lib.el    |    5 ++\r
  71  emacs/notmuch-mua.el    |    9 +++-\r
  72  emacs/notmuch-query.el  |    7 ++-\r
  73  emacs/notmuch-show.el   |   65 ++++++++++++++++++++---------\r
  74  emacs/notmuch.el        |   10 ++++-\r
  75  7 files changed, 175 insertions(+), 26 deletions(-)\r
  76  create mode 100644 emacs/notmuch-crypto.el\r
  77 \r
  78 diff --git a/emacs/Makefile.local b/emacs/Makefile.local\r
  79 index 1c09d87..1022777 100644\r
  80 --- a/emacs/Makefile.local\r
  81 +++ b/emacs/Makefile.local\r
  82 @@ -12,6 +12,7 @@ emacs_sources := \\r
  83         $(dir)/notmuch-address.el \\r
  84         $(dir)/notmuch-maildir-fcc.el \\r
  85         $(dir)/notmuch-message.el \\r
  86 +       $(dir)/notmuch-crypto.el \\r
  87         $(dir)/coolj.el\r
  88  \r
  89  emacs_images := \\r
  90 diff --git a/emacs/notmuch-crypto.el b/emacs/notmuch-crypto.el\r
  91 new file mode 100644\r
  92 index 0000000..944452b\r
  93 --- /dev/null\r
  94 +++ b/emacs/notmuch-crypto.el\r
  95 @@ -0,0 +1,104 @@\r
  96 +;; notmuch-crypto.el --- functions for handling display of cryptographic metadata.\r
  97 +;;\r
  98 +;; Copyright © Jameson Rollins\r
  99 +;;\r
 100 +;; This file is part of Notmuch.\r
 101 +;;\r
 102 +;; Notmuch is free software: you can redistribute it and/or modify it\r
 103 +;; under the terms of the GNU General Public License as published by\r
 104 +;; the Free Software Foundation, either version 3 of the License, or\r
 105 +;; (at your option) any later version.\r
 106 +;;\r
 107 +;; Notmuch is distributed in the hope that it will be useful, but\r
 108 +;; WITHOUT ANY WARRANTY; without even the implied warranty of\r
 109 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\r
 110 +;; General Public License for more details.\r
 111 +;;\r
 112 +;; You should have received a copy of the GNU General Public License\r
 113 +;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.\r
 114 +;;\r
 115 +;; Authors: Jameson Rollins <jrollins@finestructure.net>\r
 116 +\r
 117 +(defcustom notmuch-crypto-process-mime nil\r
 118 +  "Should cryptographic MIME parts be processed?\r
 119 +\r
 120 +If this variable is non-nil signatures in multipart/signed\r
 121 +messages will be verified and multipart/encrypted parts will be\r
 122 +decrypted.  The result of the crypto operation will be displayed\r
 123 +in a specially colored header button at the top of the processed\r
 124 +part.  Signed parts will have variously colored headers depending\r
 125 +on the success or failure of the verification process and on the\r
 126 +validity of user ID of the signer.\r
 127 +\r
 128 +The effect of setting this variable can be seen temporarily by\r
 129 +viewing a signed or encrypted message with M-RET in notmuch\r
 130 +search."\r
 131 +  :group 'notmuch\r
 132 +  :type 'boolean)\r
 133 +\r
 134 +(define-button-type 'notmuch-crypto-status-button-type\r
 135 +  'action '(lambda (button) (message (button-get button 'help-echo)))\r
 136 +  'follow-link t\r
 137 +  'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."\r
 138 +  'face '(:foreground "blue")\r
 139 +  'mouse-face '(:foreground "blue"))\r
 140 +\r
 141 +(defun notmuch-crypto-insert-sigstatus-button (sigstatus from)\r
 142 +  (let* ((status (plist-get sigstatus :status))\r
 143 +        (help-msg nil)\r
 144 +        (label "multipart/signed: signature not processed")\r
 145 +        (face '(:background "red" :foreground "black")))\r
 146 +    (cond\r
 147 +     ((string= status "good")\r
 148 +      ; if userid present, userid has full or greater validity\r
 149 +      (if (plist-member sigstatus :userid)\r
 150 +         (let ((userid (plist-get sigstatus :userid)))\r
 151 +           (setq label (concat "Good signature by: " userid))\r
 152 +           (setq face '(:background "green" :foreground "black")))\r
 153 +       (let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint))))\r
 154 +         (setq label (concat "Good signature by key: " fingerprint))\r
 155 +         (setq face '(:background "orange" :foreground "black")))))\r
 156 +     ((string= status "error")\r
 157 +      (let ((keyid (concat "0x" (plist-get sigstatus :keyid))))\r
 158 +       (setq label (concat "Unknown key ID " keyid " or unsupported algorithm"))\r
 159 +       (setq face '(:background "red" :foreground "black"))))\r
 160 +     ((string= status "bad")\r
 161 +      (let ((keyid (concat "0x" (plist-get sigstatus :keyid))))\r
 162 +       (setq label (concat "Bad signature (claimed key ID " keyid ")"))\r
 163 +       (setq face '(:background "red" :foreground "black"))))\r
 164 +     (t\r
 165 +      (setq label "Unknown signature status")\r
 166 +      (if status (setq label (concat label " \"" status "\"")))))\r
 167 +    (insert-button\r
 168 +     (concat "[ " label " ]")\r
 169 +     :type 'notmuch-crypto-status-button-type\r
 170 +     'help-echo help-msg\r
 171 +     'face face\r
 172 +     'mouse-face face\r
 173 +     :notmuch-sigstatus sigstatus\r
 174 +     :notmuch-from from)\r
 175 +    (insert "\n")))\r
 176 +\r
 177 +(defun notmuch-crypto-insert-encstatus-button (encstatus)\r
 178 +  (let* ((status (plist-get encstatus :status))\r
 179 +        (help-msg nil)\r
 180 +        (label "multipart/encrypted: decryption not attempted")\r
 181 +        (face '(:background "purple" :foreground "black")))\r
 182 +    (cond\r
 183 +     ((string= status "good")\r
 184 +      (setq label "decryption successful"))\r
 185 +     ((string= status "bad")\r
 186 +      (setq label "decryption error"))\r
 187 +     (t\r
 188 +      (setq label (concat "unknown encstatus \"" status "\""))))\r
 189 +    (insert-button\r
 190 +     (concat "[ multipart/encrypted: " label " ]")\r
 191 +     :type 'notmuch-crypto-status-button-type\r
 192 +     'help-echo help-msg\r
 193 +     'face face\r
 194 +     'mouse-face face)\r
 195 +    (insert "\n")))\r
 196 +\r
 197 +;;\r
 198 +\r
 199 +(provide 'notmuch-crypto)\r
 200 diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el\r
 201 index cc80fb2..1ced0f1 100644\r
 202 --- a/emacs/notmuch-lib.el\r
 203 +++ b/emacs/notmuch-lib.el\r
 204 @@ -156,5 +156,10 @@ was called."\r
 205     "Return non-nil if OBJECT is a mouse click event."\r
 206     (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))))\r
 207  \r
 208 +;; This variable is used only buffer local, but it needs to be\r
 209 +;; declared globally first to avoid compiler warnings.\r
 210 +(defvar notmuch-show-process-crypto nil)\r
 211 +(make-variable-buffer-local 'notmuch-show-process-crypto)\r
 212 +\r
 213  (provide 'notmuch-lib)\r
 214  \r
 215 diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el\r
 216 index dc7b386..003b313 100644\r
 217 --- a/emacs/notmuch-mua.el\r
 218 +++ b/emacs/notmuch-mua.el\r
 219 @@ -70,12 +70,17 @@ list."\r
 220         notmuch-mua-hidden-headers))\r
 221  \r
 222  (defun notmuch-mua-reply (query-string)\r
 223 -  (let (headers body)\r
 224 +  (let (headers\r
 225 +       body\r
 226 +       (args '("reply")))\r
 227 +    (if notmuch-show-process-crypto\r
 228 +       (setq args (append args '("--decrypt"))))\r
 229 +    (setq args (append args (list query-string)))\r
 230      ;; This make assumptions about the output of `notmuch reply', but\r
 231      ;; really only that the headers come first followed by a blank\r
 232      ;; line and then the body.\r
 233      (with-temp-buffer\r
 234 -      (call-process notmuch-command nil t nil "reply" query-string)\r
 235 +      (apply 'call-process (append (list notmuch-command nil (list t t) nil) args))\r
 236        (goto-char (point-min))\r
 237        (if (re-search-forward "^$" nil t)\r
 238           (save-excursion\r
 239 diff --git a/emacs/notmuch-query.el b/emacs/notmuch-query.el\r
 240 index 921f624..d66baea 100644\r
 241 --- a/emacs/notmuch-query.el\r
 242 +++ b/emacs/notmuch-query.el\r
 243 @@ -22,17 +22,20 @@\r
 244  (require 'notmuch-lib)\r
 245  (require 'json)\r
 246  \r
 247 -(defun notmuch-query-get-threads (search-terms &rest options)\r
 248 +(defun notmuch-query-get-threads (search-terms)\r
 249    "Return a list of threads of messages matching SEARCH-TERMS.\r
 250  \r
 251  A thread is a forest or list of trees. A tree is a two element\r
 252  list where the first element is a message, and the second element\r
 253  is a possibly empty forest of replies.\r
 254  "\r
 255 -  (let  ((args (append '("show" "--format=json") search-terms))\r
 256 +  (let  ((args '("show" "--format=json"))\r
 257          (json-object-type 'plist)\r
 258          (json-array-type 'list)\r
 259          (json-false 'nil))\r
 260 +    (if notmuch-show-process-crypto\r
 261 +       (setq args (append args '("--decrypt"))))\r
 262 +    (setq args (append args search-terms))\r
 263      (with-temp-buffer\r
 264        (progn\r
 265         (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args))\r
 266 diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el\r
 267 index 9a38d9c..e0cd41f 100644\r
 268 --- a/emacs/notmuch-show.el\r
 269 +++ b/emacs/notmuch-show.el\r
 270 @@ -32,6 +32,7 @@\r
 271  (require 'notmuch-query)\r
 272  (require 'notmuch-wash)\r
 273  (require 'notmuch-mua)\r
 274 +(require 'notmuch-crypto)\r
 275  \r
 276  (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))\r
 277  (declare-function notmuch-fontify-headers "notmuch" nil)\r
 278 @@ -295,18 +296,20 @@ message at DEPTH in the current thread."\r
 279  ;; Functions handling particular MIME parts.\r
 280  \r
 281  (defun notmuch-show-save-part (message-id nth &optional filename)\r
 282 -  (with-temp-buffer\r
 283 -    ;; Always acquires the part via `notmuch part', even if it is\r
 284 -    ;; available in the JSON output.\r
 285 -    (insert (notmuch-show-get-bodypart-internal message-id nth))\r
 286 -    (let ((file (read-file-name\r
 287 -                "Filename to save as: "\r
 288 -                (or mailcap-download-directory "~/")\r
 289 -                nil nil\r
 290 -                filename))\r
 291 -         (require-final-newline nil)\r
 292 -          (coding-system-for-write 'no-conversion))\r
 293 -      (write-region (point-min) (point-max) file))))\r
 294 +  (let ((process-crypto notmuch-show-process-crypto))\r
 295 +    (with-temp-buffer\r
 296 +      (setq notmuch-show-process-crypto process-crypto)\r
 297 +      ;; Always acquires the part via `notmuch part', even if it is\r
 298 +      ;; available in the JSON output.\r
 299 +      (insert (notmuch-show-get-bodypart-internal message-id nth))\r
 300 +      (let ((file (read-file-name\r
 301 +                  "Filename to save as: "\r
 302 +                  (or mailcap-download-directory "~/")\r
 303 +                  nil nil\r
 304 +                  filename))\r
 305 +           (require-final-newline nil)\r
 306 +           (coding-system-for-write 'no-conversion))\r
 307 +       (write-region (point-min) (point-max) file)))))\r
 308  \r
 309  (defun notmuch-show-mm-display-part-inline (msg part content-type content)\r
 310    "Use the mm-decode/mm-view functions to display a part in the\r
 311 @@ -551,13 +554,20 @@ current buffer, if possible."\r
 312  \r
 313  ;; Helper for parts which are generally not included in the default\r
 314  ;; JSON output.\r
 315 -\r
 316 +;; Uses the buffer-local variable notmuch-show-process-crypto to\r
 317 +;; determine if parts should be decrypted first.\r
 318  (defun notmuch-show-get-bodypart-internal (message-id part-number)\r
 319 -  (with-temp-buffer\r
 320 -    (let ((coding-system-for-read 'no-conversion))\r
 321 -      (call-process notmuch-command nil t nil\r
 322 -                   "show" "--format=raw" (format "--part=%s" part-number) message-id)\r
 323 -      (buffer-string))))\r
 324 +  (let ((args '("show" "--format=raw"))\r
 325 +       (part-arg (format "--part=%s" part-number)))\r
 326 +    (setq args (append args (list part-arg)))\r
 327 +    (if notmuch-show-process-crypto\r
 328 +       (setq args (append args '("--decrypt"))))\r
 329 +    (setq args (append args (list message-id)))\r
 330 +    (with-temp-buffer\r
 331 +      (let ((coding-system-for-read 'no-conversion))\r
 332 +       (progn\r
 333 +         (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args))\r
 334 +         (buffer-string))))))\r
 335  \r
 336  (defun notmuch-show-get-bodypart-content (msg part nth)\r
 337    (or (plist-get part :content)\r
 338 @@ -578,6 +588,16 @@ current buffer, if possible."\r
 339    "Insert the body part PART at depth DEPTH in the current thread."\r
 340    (let ((content-type (downcase (plist-get part :content-type)))\r
 341         (nth (plist-get part :id)))\r
 342 +    ;; add encryption status button if encstatus specified\r
 343 +    (if (plist-member part :encstatus)\r
 344 +       (let* ((encstatus (car (plist-get part :encstatus))))\r
 345 +         (notmuch-crypto-insert-encstatus-button encstatus)))\r
 346 +    ;; add signature status button if sigstatus specified\r
 347 +    (if (plist-member part :sigstatus)\r
 348 +       (let* ((headers (plist-get msg :headers))\r
 349 +              (from (plist-get headers :From))\r
 350 +              (sigstatus (car (plist-get part :sigstatus))))\r
 351 +         (notmuch-crypto-insert-sigstatus-button sigstatus from)))\r
 352      (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))\r
 353    ;; Some of the body part handlers leave point somewhere up in the\r
 354    ;; part, so we make sure that we're down at the end.\r
 355 @@ -711,9 +731,10 @@ current buffer, if possible."\r
 356    (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))\r
 357  \r
 358  (defvar notmuch-show-parent-buffer nil)\r
 359 +(make-variable-buffer-local 'notmuch-show-parent-buffer)\r
 360  \r
 361  ;;;###autoload\r
 362 -(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)\r
 363 +(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name crypto-switch)\r
 364    "Run \"notmuch show\" with the given thread ID and display results.\r
 365  \r
 366  The optional PARENT-BUFFER is the notmuch-search buffer from\r
 367 @@ -733,10 +754,14 @@ function is used. "\r
 368    (let ((buffer (get-buffer-create (generate-new-buffer-name\r
 369                                     (or buffer-name\r
 370                                         (concat "*notmuch-" thread-id "*")))))\r
 371 +       (process-crypto (if crypto-switch\r
 372 +                           (not notmuch-crypto-process-mime)\r
 373 +                         notmuch-crypto-process-mime))\r
 374         (inhibit-read-only t))\r
 375      (switch-to-buffer buffer)\r
 376      (notmuch-show-mode)\r
 377 -    (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)\r
 378 +    (setq notmuch-show-parent-buffer parent-buffer)\r
 379 +    (setq notmuch-show-process-crypto process-crypto)\r
 380      (erase-buffer)\r
 381      (goto-char (point-min))\r
 382      (save-excursion\r
 383 diff --git a/emacs/notmuch.el b/emacs/notmuch.el\r
 384 index 64f72a0..837136d 100644\r
 385 --- a/emacs/notmuch.el\r
 386 +++ b/emacs/notmuch.el\r
 387 @@ -218,6 +218,7 @@ For a mouse binding, return nil."\r
 388      (define-key map "-" 'notmuch-search-remove-tag)\r
 389      (define-key map "+" 'notmuch-search-add-tag)\r
 390      (define-key map (kbd "RET") 'notmuch-search-show-thread)\r
 391 +    (define-key map (kbd "M-RET") 'notmuch-search-show-thread-crypto-switch)\r
 392      map)\r
 393    "Keymap for \"notmuch search\" buffers.")\r
 394  (fset 'notmuch-search-mode-map notmuch-search-mode-map)\r
 395 @@ -417,7 +418,11 @@ Complete list of currently available key bindings:\r
 396    "Return a list of authors for the current region"\r
 397    (notmuch-search-properties-in-region 'notmuch-search-subject beg end))\r
 398  \r
 399 -(defun notmuch-search-show-thread ()\r
 400 +(defun notmuch-search-show-thread-crypto-switch ()\r
 401 +  (interactive)\r
 402 +  (notmuch-search-show-thread t))\r
 403 +\r
 404 +(defun notmuch-search-show-thread (&optional crypto-switch)\r
 405    "Display the currently selected thread."\r
 406    (interactive)\r
 407    (let ((thread-id (notmuch-search-find-thread-id))\r
 408 @@ -433,7 +438,8 @@ Complete list of currently available key bindings:\r
 409                          (concat "*"\r
 410                                  (truncate-string-to-width subject 32 nil nil t)\r
 411                                  "*")\r
 412 -                        32 nil nil t)))\r
 413 +                        32 nil nil t))\r
 414 +                     crypto-switch)\r
 415        (error "End of search results"))))\r
 416  \r
 417  (defun notmuch-search-reply-to-thread ()\r
 418 -- \r
 419 1.7.4.4\r
 420 \r