~pkal/autocrypt

a5d67301c160ee37117ce4d321b4095bf9af95ae — Philip Kaludercic 6 months ago 1dc4e59
Revert to custom generic backend system
5 files changed, 134 insertions(+), 156 deletions(-)

M autocrypt-gnus.el
M autocrypt-message.el
M autocrypt-mu4e.el
M autocrypt-rmail.el
M autocrypt.el
M autocrypt-gnus.el => autocrypt-gnus.el +11 -5
@@ 23,13 23,19 @@
;;; Code:

(require 'gnus)
(require 'autocrypt)

(cl-defmethod autocrypt-mode-hooks ((_mode (eql gnus)))
  "Return the hook to install autocrypt."
  '(gnus-article-prepare-hook))
;;;###autoload
(defun autocrypt-gnus--install ()
  "Prepare autocrypt for Gnus."
  (add-hook 'gnus-article-prepare-hook #'autocrypt-process-header nil t))

(cl-defmethod autocrypt-get-header ((_mode (eql gnus)) header)
  "Return the value for HEADER."
(defun autocrypt-gnus--uninstall ()
  "Undo `autocrypt-gnus--install'."
  (remove-hook 'gnus-article-prepare-hook #'autocrypt-process-header t))

(defun autocrypt-gnus--get-header (header)
  "Return value for HEADER from current message."
  (gnus-fetch-original-field header))

(provide 'autocrypt-gnus)

M autocrypt-message.el => autocrypt-message.el +18 -15
@@ 23,35 23,38 @@
;;; Code:

(require 'message)
(require 'autocrypt)

(cl-defmethod autocrypt-install ((_mode (eql message)))
  "Install autocrypt hooks for message mode."
  (add-hook 'message-setup-hook #'autocrypt-compose-setup)
  (add-hook 'message-send-hook #'autocrypt-compose-pre-send)
;;;###autoload
(defun autocrypt-message--install ()
  "Prepare autocrypt for message buffers."
  (add-hook 'message-setup-hook #'autocrypt-compose-setup nil t)
  (add-hook 'message-send-hook #'autocrypt-compose-pre-send nil t)
  (unless (lookup-key message-mode-map (kbd "C-c RET C-a"))
    (define-key message-mode-map (kbd "C-c RET C-a") #'autocrypt-compose-setup)))
    (local-set-key (kbd "C-c RET C-a") #'autocrypt-compose-setup)))

(defun autocrypt-message-uninstall ()
(defun autocrypt-message--uninstall ()
  "Remove autocrypt hooks for message mode."
  (remove-hook 'message-setup-hook #'autocrypt-compose-setup)
  (remove-hook 'message-send-hook #'autocrypt-compose-pre-send)
  (remove-hook 'message-setup-hook #'autocrypt-compose-setup t)
  (remove-hook 'message-send-hook #'autocrypt-compose-pre-send t)
  (when (eq (lookup-key message-mode-map (kbd "C-c RET C-a"))
            #'autocrypt-compose-setup)
    (define-key message-mode-map (kbd "C-c RET C-a") nil)))
    (local-set-key (kbd "C-c RET C-a") nil)))

(cl-defmethod autocrypt-get-header ((_ (eql message)) header)
(defun autocrypt-message--get-header (header)
  "Return the value for HEADER."
  (message-fetch-field header))

(cl-defmethod autocrypt-add-header ((_mode (eql message)) header value)
(defun autocrypt-message--add-header (header value)
  "Insert HEADER with VALUE into the message head."
  (message-add-header (concat header ": " value)))
  (with-silent-modifications
    (message-add-header (concat header ": " value))))

(cl-defmethod autocrypt-sign-encrypt ((_mode (eql message)))
(defun autocrypt-message--sign-encrypt ()
  "Sign and encrypt message."
  (mml-secure-message-sign-encrypt "pgpmime"))

(cl-defmethod autocrypt-sign-secure-attach ((_mode (eql message)) payload)
(defun autocrypt-message--sign-secure-attach (payload)
  "Attach and encrypt buffer PAYLOAD."
  (mml-attach-buffer payload)
  (mml-secure-part "pgpmime")


@@ 59,7 62,7 @@
            (lambda () (kill-buffer payload))
            nil t))

(cl-defmethod autocrypt-encrypted-p ((_mode (eql message)))
(defun autocrypt--message-encrypted-p ()
  "Check if the current message is encrypted."
  (mml-secure-is-encrypted-p))


M autocrypt-mu4e.el => autocrypt-mu4e.el +9 -6
@@ 22,19 22,22 @@

;;; Code:

(declare-function mu4e-view-raw-message "mu4e" () )
(require 'autocrypt)

(cl-defmethod autocrypt-install ((_mode (eql mu4e)))
(declare-function mu4e-view-raw-message "mu4e" ())

;;;###autocrypt
(defun autocrypt-mu4e--install ()
  "Install autocrypt hooks for mu4e."
  (add-hook 'mu4e-view-mode-hook #'autocrypt-process-header)
  (add-hook 'mu4e-compose-mode-hook #'autocrypt-compose-setup))
  (add-hook 'mu4e-view-mode-hook #'autocrypt-process-header nil t)
  (add-hook 'mu4e-compose-mode-hook #'autocrypt-compose-setup nil t))

(cl-defmethod autocrypt-uninstall ((_mode (eql mu4e)))
(defun autocrypt-mu4e--uninstall ()
  "Remove autocrypt hooks for mu4e."
  (remove-hook 'mu4e-view-mode-hook #'autocrypt-process-header)
  (remove-hook 'mu4e-compose-mode-hook #'autocrypt-compose-setup))

(cl-defmethod autocrypt-get-header ((_mode (eql mu4e)) header)
(defun autocrypt-mu4e--get-header (header)
  "Ask mu4e to return HEADER."
  (save-window-excursion
    (with-current-buffer (mu4e-view-raw-message)

M autocrypt-rmail.el => autocrypt-rmail.el +11 -8
@@ 22,19 22,22 @@

;;; Code:

(require 'autocrypt)
(require 'rmail)

;;; NOTE: rmail does not use derived modes, so these methods match the
;;;       exact mode.
(defun autocrypt-rmail--install ()
  "Install autocrypt functions into the current rmail buffer."
  (add-hook 'rmail-show-message-hook #'autocrypt-process-header nil t))

(cl-defmethod autocrypt-mode-hooks ((_mode (eql rmail-mode)))
  "Return the hook to install autocrypt."
  '(rmail-show-message-hook))
(defun autocrypt-rmail--uninstall ()
  "Remove autocrypt from current buffer."
  (add-hook 'rmail-show-message-hook #'autocrypt-process-header t))

(cl-defmethod autocrypt-get-header ((_mode (eql rmail-mode)) header)
(defun autocrypt-rmail--get-header (header)
  "Ask Rmail to return HEADER."
  (rmail-apply-in-message rmail-current-message
                          (lambda () (mail-fetch-field header))))
  (rmail-apply-in-message
   rmail-current-message
   (lambda () (mail-fetch-field header))))

(provide 'autocrypt-rmail)


M autocrypt.el => autocrypt.el +85 -122
@@ 26,7 26,6 @@
;;; Code:

(require 'cl-lib)
(require 'cl-generic)
(eval-when-compile (require 'rx))
(require 'epg)
(require 'ietf-drums)


@@ 35,7 34,7 @@
;;; CUSTOMIZABLES

(defgroup autocrypt nil
  "Autocrypt protocol implementation for Emacs MUAs"
  "Autocrypt protocol implementation for Emacs MUAs."
  :tag "Autocrypt"
  :group 'mail
  :link '(url-link "https://autocrypt.org/")


@@ 72,18 71,6 @@ process \"Autocrypt-Gossip\" headers when received."

;;; INTERNAL STATE

(defvar autocrypt-backends
  '(((mu4e-main-mode mu4e-view-mode) mu4e autocrypt-mu4e)
    ((gnus-mode) gnus autocrypt-gnus)
    ((rmail-mode) rmail autocrypt-rmail)
    ((message-mode) message autocrypt-message))
  "Alist of supported backends.
Each entry consists of a list of major modes, the method
specializer and optionally the feature that has to be loaded.")

(defvar-local autocrypt-current-backend nil
  "Currently active backend.")

(defvar autocrypt-accounts nil
  "Alist of supported Autocrypt accounts.



@@ 112,90 99,74 @@ Every member of this list has to be an instance of the

;;; MUA TRANSLATION LAYER

(cl-defgeneric autocrypt-mode-hooks (mode)
  "Return a list of hooks for MODE that process headers.")
(defvar autocrypt-backends
  '(((mu4e-main-mode mu4e-view-mode) . mu4e)
    ((gnus-mode) . gnus)
    ((rmail-mode) . rmail)
    ((message-mode) . message))
  "Alist of known backends.
Each entry has the form (MODES . NAME), where MODES is a list of
major modes where the backend applies, and NAME is a symbol to
designate this backend.")

(defvar-local autocrypt-backend-function nil
  "Override the function called by `autocrypt-find-function'.
This function must accept one argument, a symbol designating the
command (`install', `get-header', ...) and returns a function
with the right signature.")

(defun autocrypt-find-function (command)
  "Return a function for handling COMMAND."
  (if autocrypt-backend-function
      (funcall autocrypt-backend-function command)
    (catch 'ok
      (dolist (backend-data autocrypt-backends)
        (let ((modes (car backend-data))
              (backend (cdr backend-data)))
          (when (apply #'derived-mode-p modes)
            (dolist (fn (mapcar
                         #'intern
                         (list (format "autocrypt-%S--%S" backend command)
                               (format "%S-autocrypt-%S" backend command)
                               (format "%S--autocrypt-%S" backend command))))
              (when (and fn (fboundp fn))
                (throw 'ok fn))))))
      (error "No autocrypt backend found"))))

(defun autocrypt-make-function (command signature)
  "Return a function to handle COMMAND.
The advertised calling convention is set to SIGNATURE."
  (let ((f (lambda (&rest args)
             (apply (autocrypt-find-function command) args))))
    (set-advertised-calling-convention f signature nil)
    f))

(defalias 'autocrypt-install (autocrypt-make-function 'install '())
  "Install necessary autocrypt functions into the MUA.")

(defalias 'autocrypt-uninstall (autocrypt-make-function 'uninstall '())
  "Remove all modifications by autocrypt.")

(defalias 'autocrypt-get-header (autocrypt-make-function 'get-header '(header))
  "Return the value of HEADER.")

(cl-defgeneric autocrypt-install (mode)
  "Install autocrypt for MODE."
  (dolist (hook (autocrypt-mode-hooks mode))
    (add-hook hook #'autocrypt-process-header)))
(defalias 'autocrypt-add-header (autocrypt-make-function 'add-header '(header value))
  "Insert HEADER with VALUE into message.")

(defun autocrypt--install ()
  "Install necessary autocrypt functions into the MUA."
  (cl-assert autocrypt-current-backend)
  (autocrypt-install autocrypt-current-backend))
(defalias 'autocrypt-remove-header (autocrypt-make-function 'remove-header '(header))
  "Remove HEADER from message.")

(cl-defgeneric autocrypt-uninstall (mode)
  "Undo `autocrypt-install' for MODE."
  (dolist (hook (autocrypt-mode-hooks mode))
    (remove-hook hook #'autocrypt-process-header)))
(defalias 'autocrypt-sign-encrypt (autocrypt-make-function 'sign-encrypt '())
  "Make the message to be signed and encrypted.")

(defun autocrypt--uninstall ()
  "Remove all modifications by autocrypt."
  (cl-assert autocrypt-current-backend)
  (autocrypt-install autocrypt-current-backend))
(defalias 'autocrypt-secure-attach (autocrypt-make-function 'secure-attach '(payload))
  "Add PAYLOAD as an encrypted attachment.")

(cl-defgeneric autocrypt-get-header (_mode _header)
  "Return the value of HEADER.")
(defalias 'autocrypt-encrypted-p (autocrypt-make-function 'encrypted-p '())
  "Check the the current message is encrypted.")

(defun autocrypt--get-header (header)
  "Return the value of HEADER."
  (cl-assert autocrypt-current-backend)
  (autocrypt-get-header autocrypt-current-backend header))

(cl-defgeneric autocrypt-add-header (_mode _header _value)
  "Insert HEADER with VALUE into message."
  'n/a)

(defun autocrypt--add-header (header value)
  "Insert HEADER with VALUE into message."
  (cl-assert autocrypt-current-backend)
  (autocrypt-add-header autocrypt-current-backend header value))

(cl-defgeneric autocrypt-remove-header (_mode _header)
  "Remove HEADER from message."
  'n/a)

(defun autocrypt--remove-header (header)
  "Remove HEADER from message."
  (cl-assert autocrypt-current-backend)
  (autocrypt-remove-header autocrypt-current-backend header))

(cl-defgeneric autocrypt-sign-encrypt (_mode)
  "Sign and encrypt this message."
  'n/a)

(defun autocrypt--sign-encrypt ()
  "Sign and encrypt this message."
  (cl-assert autocrypt-current-backend)
  (autocrypt-sign-encrypt autocrypt-current-backend))

(cl-defgeneric autocrypt-secure-attach (_mode _payload)
  "Add PAYLOAD as an encrypted attachment."
  'n/a)

(defun autocrypt--secure-attach (payload)
  "Add PAYLOAD as an encrypted attachment."
  (cl-assert autocrypt-current-backend)
  (autocrypt--secure-attach autocrypt-current-backend payload))

(cl-defgeneric autocrypt-encrypted-p (_mode)
  "Check the the current message is encrypted."
  'n/a)

(defun autocrypt--encrypted-p ()
  "Check the the current message is encrypted."
  (cl-assert autocrypt-current-backend)
  (autocrypt-encrypted-p autocrypt-current-backend))

(cl-defgeneric autocrypt-get-part (_mode _nr)
  "Return the NR'th part of the current message."
  'n/a)

(defun autocrypt--get-part (nr)
  "Return the NR'th part of the current message."
  (cl-assert autocrypt-current-backend)
  (autocrypt-get-part autocrypt-current-backend nr))
(defalias 'autocrypt-get-part (autocrypt-make-function 'get-part '(index))
  "Return the INDEX'th part of the current message.")


;;; INTERNAL FUNCTIONS


@@ 300,7 271,7 @@ well-formed, otherwise returns just nil."
  "Return a list of all recipients to this message."
  (let (recipients)
    (dolist (header '("To" "Cc" "Reply-To"))
      (let* ((f (autocrypt--get-header header))
      (let* ((f (autocrypt-get-header header))
             (r (and f (mail-extract-address-components f t))))
        (setq recipients (nconc (mapcar #'cadr r) recipients))))
    (delete-dups recipients)))


@@ 311,7 282,7 @@ well-formed, otherwise returns just nil."

Argument DATE contains the time value of the \"From\" tag."
  (let ((recip (autocrypt-list-recipients))
        (root (autocrypt--get-part 0))
        (root (autocrypt-get-part 0))
        (re (rx bol "Autocrypt-Gossip:" (* space)
                (group (+ (or nonl (: "\n "))))
                eol))


@@ 357,9 328,9 @@ Argument DATE contains the time value of the \"From\" tag."
;; https://autocrypt.org/level1.html#updating-autocrypt-peer-state
(defun autocrypt-process-header ()
  "Update internal autocrypt state."
  (let* ((from (autocrypt-canonicalise (autocrypt--get-header "From")))
         (date (ietf-drums-parse-date (autocrypt--get-header "Date")))
         (header (autocrypt--get-header "Autocrypt"))
  (let* ((from (autocrypt-canonicalise (autocrypt-get-header "From")))
         (date (ietf-drums-parse-date (autocrypt-get-header "Date")))
         (header (autocrypt-get-header "Autocrypt"))
         parse addr preference keydata peer)
    (when header
      (when (setq parse (autocrypt-parse-header header))


@@ 446,7 417,7 @@ preference (\"prefer-encrypt\")."
Argument RECIPIENTS is a list of addresses this message is
addressed to."
  (and autocrypt-do-gossip
       (autocrypt--encrypted-p)
       (autocrypt-encrypted-p)
       (< 1 (length recipients))
       (cl-every
        (lambda (rec)


@@ 458,39 429,39 @@ addressed to."
  "Check if Autocrypt is possible, and add pseudo headers."
  (interactive)
  (let ((recs (autocrypt-list-recipients))
        (from (autocrypt-canonicalise (autocrypt--get-header "From"))))
        (from (autocrypt-canonicalise (autocrypt-get-header "From"))))
    ;; encrypt message if applicable
    (save-excursion
      (cl-case (autocrypt-recommendation from recs)
        (encrypt
         (autocrypt--sign-encrypt))
         (autocrypt-sign-encrypt))
        (available
         (autocrypt--add-header "Do-Autocrypt" "no"))
         (autocrypt-add-header "Do-Autocrypt" "no"))
        (discourage
         (autocrypt--add-header "Do-Discouraged-Autocrypt" "no"))))))
         (autocrypt-add-header "Do-Discouraged-Autocrypt" "no"))))))

(defun autocrypt-compose-pre-send ()
  "Insert Autocrypt headers before sending a message.

Will handle and remove \"Do-(Discourage-)Autocrypt\" if found."
  (let* ((recs (autocrypt-list-recipients))
         (from (autocrypt-canonicalise (autocrypt--get-header "From"))))
         (from (autocrypt-canonicalise (autocrypt-get-header "From"))))
    ;; encrypt message if applicable
    (when (eq (autocrypt-recommendation from recs) 'encrypt)
      (autocrypt--sign-encrypt))
      (autocrypt-sign-encrypt))
    ;; check for manual autocrypt confirmations
    (let ((do-autocrypt (autocrypt--get-header "Do-Autocrypt"))
          (ddo-autocrypt (autocrypt--get-header "Do-Discouraged-Autocrypt"))
    (let ((do-autocrypt (autocrypt-get-header "Do-Autocrypt"))
          (ddo-autocrypt (autocrypt-get-header "Do-Discouraged-Autocrypt"))
          (query "Are you sure you want to use Autocrypt, even though it is discouraged?"))
      (when (and (not (autocrypt--encrypted-p))
      (when (and (not (autocrypt-encrypted-p))
                 (or (and do-autocrypt
                          (string= (downcase do-autocrypt) "yes"))
                     (and ddo-autocrypt
                          (string= (downcase ddo-autocrypt) "yes")
                          (yes-or-no-p query))))
        (autocrypt--sign-encrypt)))
    (autocrypt--remove-header "Do-Autocrypt")
    (autocrypt--remove-header "Do-Discouraged-Autocrypt")
        (autocrypt-sign-encrypt)))
    (autocrypt-remove-header "Do-Autocrypt")
    (autocrypt-remove-header "Do-Discouraged-Autocrypt")
    ;; insert gossip data
    (when (autocrypt-gossip-p recs)
      (let ((payload (generate-new-buffer " *autocrypt gossip*")))


@@ 498,11 469,11 @@ Will handle and remove \"Do-(Discourage-)Autocrypt\" if found."
          (dolist (addr (autocrypt-list-recipients))
            (let ((header (autocrypt-generate-header addr t)))
              (insert "Autocrypt-Gossip: " header "\n"))))
        (autocrypt--secure-attach payload)))
        (autocrypt-secure-attach payload)))
    ;; insert autocrypt header
    (let ((header (and from (autocrypt-generate-header from))))
      (when header
        (autocrypt--add-header "Autocrypt" header)))))
        (autocrypt-add-header "Autocrypt" header)))))

;;;###autoload
(defun autocrypt-create-account ()


@@ 552,16 523,8 @@ Will handle and remove \"Do-(Discourage-)Autocrypt\" if found."
  (if autocrypt-mode
      (progn
        (autocrypt-load-data)
        (catch 'found
          (dolist (backend autocrypt-backends)
            (when (apply #'derived-mode-p (car backend))
              (setq autocrypt-current-backend (cadr backend))
              (when (caddr backend)
                (require (caddr backend)))
              (throw 'found nil)))
          (error "No autocrypt backend found"))
        (autocrypt--install))
    (autocrypt--uninstall)))
        (autocrypt-install))
    (autocrypt-uninstall)))

(provide 'autocrypt)