[autocrypt RFC PATCH] Add support for the notmuch mua

classic Classic list List threaded Threaded
1 message Options
David Edmondson David Edmondson
Reply | Threaded
Open this post in threaded view
|

[autocrypt RFC PATCH] Add support for the notmuch mua

---
This is very much an RFC patch, as I'm new to autocrypt. It's also a
patch for autocrypt (https://git.sr.ht/~zge/autocrypt) rather than
notmuch, but it made more sense to send it here first, I think.

Comments welcomed.

 autocrypt-notmuch.el | 103 +++++++++++++++++++++++++++++++++++++++++++
 autocrypt.el         |  11 +++++
 2 files changed, 114 insertions(+)
 create mode 100644 autocrypt-notmuch.el

diff --git a/autocrypt-notmuch.el b/autocrypt-notmuch.el
new file mode 100644
index 0000000..f365be2
--- /dev/null
+++ b/autocrypt-notmuch.el
@@ -0,0 +1,103 @@
+;;; autocrypt-notmuch.el --- Autocrypt for Notmuch -*- lexical-binding:t -*-
+
+;; Author: David Edmondson <[hidden email]>
+;; Version: 0.4.0
+;; Keywords: comm
+;; Package-Requires: ((emacs "25.1"))
+;; URL: https://git.sr.ht/~zge/autocrypt
+
+;; This file is NOT part of Emacs.
+;;
+;; This file is in the public domain, to the extent possible under law,
+;; published under the CC0 1.0 Universal license.
+;;
+;; For a full copy of the CC0 license see
+;; https://creativecommons.org/publicdomain/zero/1.0/legalcode
+
+;;; Commentary:
+
+;; MUA specific functions for Notmuch
+;;
+;; Set up with:
+;;   (autocrypt-notmuch-install)
+
+;;; Code:
+
+(eval-when-compile
+  (require 'pcase))
+
+(require 'notmuch-show)
+
+(defvar autocrypt-notmuch-headers-id nil)
+(defvar autocrypt-notmuch-headers-cache nil)
+
+;;;###autoload
+(defun autocrypt-notmuch-install ()
+  "Install autocrypt hooks for Notmuch."
+  (add-hook 'notmuch-show-insert-msg-hook #'autocrypt-process-header))
+
+(defun autocrypt-notmuch-uninstall ()
+  "Remove autocrypt hooks for Notmuch."
+  (remove-hook 'notmuch-show-insert-msg-hook #'autocrypt-process-header)
+
+  (when (and (bufferp autocrypt-notmuch-headers-cache)
+             (buffer-live-p autocrypt-notmuch-headers-cache))
+    (kill-buffer autocrypt-notmuch-headers-cache)))
+
+(defun autocrypt-notmuch-header-1 (field)
+  "Return the FIELD header for the currently shown message."
+
+  ;; Currently it is can be expensive to retrieve FIELD if the message
+  ;; is large, as this function examines a raw copy of the complete
+  ;; message in a buffer. Given that autocrypt will require several
+  ;; headers from each message and therefore make repeated calls to
+  ;; `autocrypt-notmuch-header', attempt to alleviate this cost using
+  ;; a single element cache containing the headers of any requested
+  ;; message.
+
+  ;; This would be improved if:
+  ;;   notmuch show --format=raw --body=false
+  ;; worked.
+
+  (let ((id (notmuch-show-get-message-id t)))
+    ;; If the current header cache is not for this message, make it
+    ;; so.
+    (unless (and (string= id autocrypt-notmuch-headers-id)
+                 (bufferp autocrypt-notmuch-headers-cache)
+                 (buffer-live-p autocrypt-notmuch-headers-cache))
+      (setq autocrypt-notmuch-headers-id id
+            autocrypt-notmuch-headers-cache (get-buffer-create "*autocrypt-notmuch-headers-cache*"))
+
+      (with-current-notmuch-show-message
+       ;; Keep only the headers in the cache - the body is not
+       ;; required.
+       (mail-narrow-to-head)
+
+       (let ((content (buffer-substring (point-min) (point-max))))
+         (with-current-buffer autocrypt-notmuch-headers-cache
+           (erase-buffer)
+           (insert content))))))
+
+  (with-current-buffer autocrypt-notmuch-headers-cache
+    (mail-fetch-field field)))
+
+(defun autocrypt-notmuch-header (field)
+  "Ask Notmuch to return header FIELD for the current message."
+
+  (pcase field
+    ;; Some headers are cached in the message properties - retrieving
+    ;; them is faster than extracting the raw message and parsing it.
+    ("Cc" (notmuch-show-get-date))
+    ("Date" (notmuch-show-get-date))
+    ("From" (notmuch-show-get-from))
+    ("To" (notmuch-show-get-date))
+    (_
+     ;; If this is not a matching message, don't bother looking more
+     ;; deeply, given that `autocrypt-notmuch-headers-1' can be
+     ;; expensive for large messages.
+     (when (plist-get (notmuch-show-get-message-properties) :match)
+       (autocrypt-notmuch-header-1 field)))))
+
+(provide 'autocrypt-notmuch)
+
+;;; autocrypt-notmuch.el ends here
diff --git a/autocrypt.el b/autocrypt.el
index 965f661..01c36c1 100644
--- a/autocrypt.el
+++ b/autocrypt.el
@@ -115,6 +115,15 @@ Every member of this list has to be an instance of the
      :sign-encrypt autocrypt-message-sign-encrypt
      :secure-attach autocrypt-message-secure-attach
      :encrypted-p mml-secure-is-encrypted-p)
+    (notmuch
+     :install autocrypt-notmuch-install
+     :uninstall autocrypt-notmuch-uninstall
+     :header autocrypt-notmuch-header
+     :add-header autocrypt-message-add-header
+     :remove-header message-remove-header
+     :sign-encrypt autocrypt-message-sign-encrypt
+     :secure-attach autocrypt-message-secure-attach
+     :encrypted-p mml-secure-is-encrypted-p)
     (message
      :install autocrypt-message-install
      :uninstall autocrypt-message-uninstall
@@ -154,6 +163,8 @@ the part contents can be found.")
 The key should identify a record in the
 `autocrypt-mua-func-alist' alist."
   (cond
+   ((derived-mode-p 'notmuch-show-mode)
+    'notmuch)
    ((derived-mode-p 'mu4e-main-mode 'mu4e-view-mode)
     'mu4e)
    ((derived-mode-p 'gnus-mode)
--
2.29.2
_______________________________________________
notmuch mailing list -- [hidden email]
To unsubscribe send an email to [hidden email]