X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml2015.el;h=e2e99771801c1031904c3e039b4dd17f1bb4e3ad;hp=8add5e5215f27170c17c8bd5256b762825464732;hb=7067d9be35e2177e6b891ede1db93f9af6c7e234;hpb=fc9d1de3b9014466008751849d606de63c6a83ae diff --git a/lisp/mml2015.el b/lisp/mml2015.el index 8add5e521..e2e997718 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -1,27 +1,24 @@ ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2000-2016 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: PGP MIME MML ;; This file is part of GNU Emacs. -;; GNU Emacs 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, or (at your -;; option) any later version. +;; GNU Emacs 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. -;; GNU Emacs 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. +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -30,9 +27,10 @@ ;;; Code: -;; For Emacs < 22.2. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (if (locate-library "password-cache") + (require 'password-cache) + (require 'password))) (eval-when-compile (require 'cl)) (require 'mm-decode) @@ -46,26 +44,24 @@ (config &optional minimum-version)) (declare-function epg-configuration "ext:epg-config" ()) +;; Maybe this should be in eg mml-sec.el (and have a different name). +;; Then mml1991 would not need to require mml2015, and mml1991-use +;; could be removed. (defvar mml2015-use (or - (condition-case nil - (progn - (require 'epg-config) - (epg-check-configuration (epg-configuration)) - 'epg) - (error)) (progn - (ignore-errors - ;; Avoid the "Recursive load suspected" error - ;; in Emacs 21.1. - (let ((recursive-load-depth-limit 100)) - (require 'pgg))) - (and (fboundp 'pgg-sign-region) - 'pgg)) + (ignore-errors (require 'epg-config)) + (and (fboundp 'epg-check-configuration) + 'epg)) (progn - (ignore-errors - (require 'gpg)) - (and (fboundp 'gpg-sign-detached) - 'gpg)) + (let ((abs-file (locate-library "pgg"))) + ;; Don't load PGG if it is marked as obsolete + ;; (Emacs 24). + (when (and abs-file + (not (string-match "/obsolete/[^/]*\\'" + abs-file))) + (ignore-errors (require 'pgg)) + (and (fboundp 'pgg-sign-region) + 'pgg)))) (progn (ignore-errors (load "mc-toplev")) (and (fboundp 'mc-encrypt-generic) @@ -73,7 +69,7 @@ (fboundp 'mc-cleanup-recipient-headers) 'mailcrypt))) "The package used for PGP/MIME. -Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") +Valid packages include `epg', `pgg' and `mailcrypt'.") ;; Something is not RFC2015. (defvar mml2015-function-alist @@ -83,24 +79,18 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") mml2015-mailcrypt-decrypt mml2015-mailcrypt-clear-verify mml2015-mailcrypt-clear-decrypt) - (gpg mml2015-gpg-sign - mml2015-gpg-encrypt - mml2015-gpg-verify - mml2015-gpg-decrypt - mml2015-gpg-clear-verify - mml2015-gpg-clear-decrypt) - (pgg mml2015-pgg-sign - mml2015-pgg-encrypt - mml2015-pgg-verify - mml2015-pgg-decrypt - mml2015-pgg-clear-verify - mml2015-pgg-clear-decrypt) - (epg mml2015-epg-sign - mml2015-epg-encrypt - mml2015-epg-verify - mml2015-epg-decrypt - mml2015-epg-clear-verify - mml2015-epg-clear-decrypt)) + (pgg mml2015-pgg-sign + mml2015-pgg-encrypt + mml2015-pgg-verify + mml2015-pgg-decrypt + mml2015-pgg-clear-verify + mml2015-pgg-clear-decrypt) + (epg mml2015-epg-sign + mml2015-epg-encrypt + mml2015-epg-verify + mml2015-epg-decrypt + mml2015-epg-clear-verify + mml2015-epg-clear-decrypt)) "Alist of PGP/MIME functions.") (defvar mml2015-result-buffer nil) @@ -117,15 +107,13 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") :type '(repeat (cons (regexp :tag "GnuPG output regexp") (boolean :tag "Trust key")))) -(defcustom mml2015-verbose mml-secure-verbose - "If non-nil, ask the user about the current operation more verbosely." - :group 'mime-security - :type 'boolean) - (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase "If t, cache passphrase." :group 'mime-security :type 'boolean) +(make-obsolete-variable 'mml2015-cache-passphrase + 'mml-secure-cache-passphrase + "25.1") (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry "How many seconds the passphrase is cached. @@ -133,12 +121,22 @@ Whether the passphrase is cached at all is controlled by `mml2015-cache-passphrase'." :group 'mime-security :type 'integer) +(make-obsolete-variable 'mml2015-passphrase-cache-expiry + 'mml-secure-passphrase-cache-expiry + "25.1") (defcustom mml2015-signers nil - "A list of your own key ID which will be used to sign a message." + "A list of your own key ID(s) which will be used to sign a message. +If set, it overrides the setting of `mml2015-sign-with-sender'." :group 'mime-security :type '(repeat (string :tag "Key ID"))) +(defcustom mml2015-sign-with-sender nil + "If t, use message sender so find a key to sign with." + :group 'mime-security + :type 'boolean + :version "24.1") + (defcustom mml2015-encrypt-to-self nil "If t, add your own key ID to recipient list when encryption." :group 'mime-security @@ -149,9 +147,21 @@ Whether the passphrase is cached at all is controlled by :group 'mime-security :type 'boolean) +(defcustom mml2015-maximum-key-image-dimension 64 + "The maximum dimension (width or height) of any key images." + :version "24.4" + :group 'mime-security + :type 'integer) + +(defcustom mml2015-display-key-image t + "If t, try to display key images." + :version "24.5" + :group 'mime-security + :type 'boolean) + ;; Extract plaintext from cleartext signature. IMO, this kind of task ;; should be done by GnuPG rather than Elisp, but older PGP backends -;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG. +;; (such as Mailcrypt, and PGG) discard the output from GnuPG. (defun mml2015-extract-cleartext-signature () ;; Daiki Ueno in ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still @@ -184,16 +194,12 @@ Whether the passphrase is cached at all is controlled by ;;; mailcrypt wrapper -(eval-and-compile - (autoload 'mailcrypt-decrypt "mailcrypt") - (autoload 'mailcrypt-verify "mailcrypt") - (autoload 'mc-pgp-always-sign "mailcrypt") - (autoload 'mc-encrypt-generic "mc-toplev") - (autoload 'mc-cleanup-recipient-headers "mc-toplev") - (autoload 'mc-sign-generic "mc-toplev")) - -(defvar mc-default-scheme) -(defvar mc-schemes) +(autoload 'mailcrypt-decrypt "mailcrypt") +(autoload 'mailcrypt-verify "mailcrypt") +(autoload 'mc-pgp-always-sign "mailcrypt") +(autoload 'mc-encrypt-generic "mc-toplev") +(autoload 'mc-cleanup-recipient-headers "mc-toplev") +(autoload 'mc-sign-generic "mc-toplev") (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) @@ -241,6 +247,58 @@ Whether the passphrase is cached at all is controlled by handles (list handles))))) +(defun mml2015-gpg-pretty-print-fpr (fingerprint) + (let* ((result "") + (fpr-length (string-width fingerprint)) + (n-slice 0) + slice) + (setq fingerprint (string-to-list fingerprint)) + (while fingerprint + (setq fpr-length (- fpr-length 4)) + (setq slice (butlast fingerprint fpr-length)) + (setq fingerprint (nthcdr 4 fingerprint)) + (setq n-slice (1+ n-slice)) + (setq result + (concat + result + (case n-slice + (1 slice) + (otherwise (concat " " slice)))))) + result)) + +(defun mml2015-gpg-extract-signature-details () + (goto-char (point-min)) + (let* ((expired (re-search-forward + "^\\[GNUPG:\\] SIGEXPIRED$" + nil t)) + (signer (and (re-search-forward + "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" + nil t) + (cons (match-string 1) (match-string 2)))) + (fprint (and (re-search-forward + "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " + nil t) + (match-string 1))) + (trust (and (re-search-forward + "^\\[GNUPG:\\] \\(TRUST_.*\\)$" + nil t) + (match-string 1))) + (trust-good-enough-p + (cdr (assoc trust mml2015-unabbrev-trust-alist)))) + (cond ((and signer fprint) + (concat (cdr signer) + (unless trust-good-enough-p + (concat "\nUntrusted, Fingerprint: " + (mml2015-gpg-pretty-print-fpr fprint))) + (when expired + (format "\nWARNING: Signature from expired key (%s)" + (car signer))))) + ((re-search-forward + "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) + (match-string 2)) + (t + "From unknown user")))) + (defun mml2015-mailcrypt-clear-decrypt () (let (result) (setq result @@ -453,292 +511,17 @@ Whether the passphrase is cached at all is controlled by (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) -;;; gpg wrapper - -(eval-and-compile - (autoload 'gpg-decrypt "gpg") - (autoload 'gpg-verify "gpg") - (autoload 'gpg-verify-cleartext "gpg") - (autoload 'gpg-sign-detached "gpg") - (autoload 'gpg-sign-encrypt "gpg") - (autoload 'gpg-encrypt "gpg") - (autoload 'gpg-passphrase-read "gpg")) - -(defun mml2015-gpg-passphrase () - (or (message-options-get 'gpg-passphrase) - (message-options-set 'gpg-passphrase (gpg-passphrase-read)))) - -(defun mml2015-gpg-decrypt-1 () - (let ((cipher (current-buffer)) plain result) - (if (with-temp-buffer - (prog1 - (gpg-decrypt cipher (setq plain (current-buffer)) - mml2015-result-buffer nil) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string))) - (set-buffer cipher) - (erase-buffer) - (insert-buffer-substring plain) - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n" t t)))) - '(t) - ;; Some wrong with the return value, check plain text buffer. - (if (> (point-max) (point-min)) - '(t) - nil)))) - -(defun mml2015-gpg-decrypt (handle ctl) - (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1)) - (mml2015-mailcrypt-decrypt handle ctl))) - -(defun mml2015-gpg-clear-decrypt () - (let (result) - (setq result (mml2015-gpg-decrypt-1)) - (if (car result) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) - -(defun mml2015-gpg-pretty-print-fpr (fingerprint) - (let* ((result "") - (fpr-length (string-width fingerprint)) - (n-slice 0) - slice) - (setq fingerprint (string-to-list fingerprint)) - (while fingerprint - (setq fpr-length (- fpr-length 4)) - (setq slice (butlast fingerprint fpr-length)) - (setq fingerprint (nthcdr 4 fingerprint)) - (setq n-slice (1+ n-slice)) - (setq result - (concat - result - (case n-slice - (1 slice) - (otherwise (concat " " slice)))))) - result)) - -(defun mml2015-gpg-extract-signature-details () - (goto-char (point-min)) - (let* ((expired (re-search-forward - "^\\[GNUPG:\\] SIGEXPIRED$" - nil t)) - (signer (and (re-search-forward - "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" - nil t) - (cons (match-string 1) (match-string 2)))) - (fprint (and (re-search-forward - "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " - nil t) - (match-string 1))) - (trust (and (re-search-forward - "^\\[GNUPG:\\] \\(TRUST_.*\\)$" - nil t) - (match-string 1))) - (trust-good-enough-p - (cdr (assoc trust mml2015-unabbrev-trust-alist)))) - (cond ((and signer fprint) - (concat (cdr signer) - (unless trust-good-enough-p - (concat "\nUntrusted, Fingerprint: " - (mml2015-gpg-pretty-print-fpr fprint))) - (when expired - (format "\nWARNING: Signature from expired key (%s)" - (car signer))))) - ((re-search-forward - "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) - (match-string 2)) - (t - "From unknown user")))) - -(defun mml2015-gpg-verify (handle ctl) - (catch 'error - (let (part message signature info-is-set-p) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mm-handle-multipart-ctl-parameter - ctl 'protocol) - "application/pgp-signature") - t)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Corrupted") - (throw 'error handle)) - (with-temp-buffer - (setq message (current-buffer)) - (insert part) - ;; Convert to in signed text. If --textmode is - ;; specified when signing, the conversion is not necessary. - (goto-char (point-min)) - (end-of-line) - (while (not (eobp)) - (unless (eq (char-before) ?\r) - (insert "\r")) - (forward-line) - (end-of-line)) - (with-temp-buffer - (setq signature (current-buffer)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Corrupted") - (throw 'error handle)) - (mm-insert-part part) - (unless (condition-case err - (prog1 - (gpg-verify message signature mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (mml2015-format-error err)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Error.") - (setq info-is-set-p t) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Quit.") - (setq info-is-set-p t) - nil)) - (unless info-is-set-p - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")) - (throw 'error handle))) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info - (with-current-buffer mml2015-result-buffer - (mml2015-gpg-extract-signature-details)))) - handle))) - -(defun mml2015-gpg-clear-verify () - (if (condition-case err - (prog1 - (gpg-verify-cleartext (current-buffer) mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (mml2015-format-error err)) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info - (with-current-buffer mml2015-result-buffer - (mml2015-gpg-extract-signature-details))) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")) - (mml2015-extract-cleartext-signature)) - -(defun mml2015-gpg-sign (cont) - (let ((boundary (mml-compute-boundary cont)) - (text (current-buffer)) signature) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (with-temp-buffer - (unless (gpg-sign-detached text (setq signature (current-buffer)) - mml2015-result-buffer - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer mml2015-result-buffer) - (error "Sign error"))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (set-buffer text) - (goto-char (point-min)) - (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" - boundary)) - ;;; FIXME: what is the micalg? - (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n") - (insert (format "\n--%s\n" boundary)) - (goto-char (point-max)) - (insert (format "\n--%s\n" boundary)) - (insert "Content-Type: application/pgp-signature\n\n") - (insert-buffer-substring signature) - (goto-char (point-max)) - (insert (format "--%s--\n" boundary)) - (goto-char (point-max))))) - -(defun mml2015-gpg-encrypt (cont &optional sign) - (let ((boundary (mml-compute-boundary cont)) - (text (current-buffer)) - cipher) - (mm-with-unibyte-current-buffer - (with-temp-buffer - ;; set up a function to call the correct gpg encrypt routine - ;; with the right arguments. (FIXME: this should be done - ;; differently.) - (flet ((gpg-encrypt-func - (sign plaintext ciphertext result recipients &optional - passphrase sign-with-key armor textmode) - (if sign - (gpg-sign-encrypt - plaintext ciphertext result recipients passphrase - sign-with-key armor textmode) - (gpg-encrypt - plaintext ciphertext result recipients passphrase - armor textmode)))) - (unless (gpg-encrypt-func - sign ; passed in when using signencrypt - text (setq cipher (current-buffer)) - mml2015-result-buffer - (split-string - (or - (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+") - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer mml2015-result-buffer) - (error "Encrypt error")))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (set-buffer text) - (delete-region (point-min) (point-max)) - (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" - boundary)) - (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") - (insert (format "--%s\n" boundary)) - (insert "Content-Type: application/pgp-encrypted\n\n") - (insert "Version: 1\n\n") - (insert (format "--%s\n" boundary)) - (insert "Content-Type: application/octet-stream\n\n") - (insert-buffer-substring cipher) - (goto-char (point-max)) - (insert (format "--%s--\n" boundary)) - (goto-char (point-max)))))) - ;;; pgg wrapper (defvar pgg-default-user-id) (defvar pgg-errors-buffer) (defvar pgg-output-buffer) -(eval-and-compile - (autoload 'pgg-decrypt-region "pgg") - (autoload 'pgg-verify-region "pgg") - (autoload 'pgg-sign-region "pgg") - (autoload 'pgg-encrypt-region "pgg") - (autoload 'pgg-parse-armor "pgg-parse")) +(autoload 'pgg-decrypt-region "pgg") +(autoload 'pgg-verify-region "pgg") +(autoload 'pgg-sign-region "pgg") +(autoload 'pgg-encrypt-region "pgg") +(autoload 'pgg-parse-armor "pgg-parse") (defun mml2015-pgg-decrypt (handle ctl) (catch 'error @@ -968,66 +751,77 @@ Whether the passphrase is cached at all is controlled by (defvar epg-user-id-alist) (defvar epg-digest-algorithm-alist) +(defvar epg-gpg-program) (defvar inhibit-redisplay) -(eval-and-compile - (autoload 'epg-make-context "epg") - (autoload 'epg-context-set-armor "epg") - (autoload 'epg-context-set-textmode "epg") - (autoload 'epg-context-set-signers "epg") - (autoload 'epg-context-result-for "epg") - (autoload 'epg-new-signature-digest-algorithm "epg") - (autoload 'epg-verify-result-to-string "epg") - (autoload 'epg-list-keys "epg") - (autoload 'epg-decrypt-string "epg") - (autoload 'epg-verify-string "epg") - (autoload 'epg-sign-string "epg") - (autoload 'epg-encrypt-string "epg") - (autoload 'epg-passphrase-callback-function "epg") - (autoload 'epg-context-set-passphrase-callback "epg") - (autoload 'epg-key-sub-key-list "epg") - (autoload 'epg-sub-key-capability "epg") - (autoload 'epg-sub-key-validity "epg") - (autoload 'epg-configuration "epg-config") - (autoload 'epg-expand-group "epg-config") - (autoload 'epa-select-keys "epa")) - -(defvar password-cache-expiry) - -(defvar mml2015-epg-secret-key-id-list nil) - -(defun mml2015-epg-passphrase-callback (context key-id ignore) - (if (eq key-id 'SYM) - (epg-passphrase-callback-function context key-id nil) - (let* (entry - (passphrase - (password-read - (if (eq key-id 'PIN) - "Passphrase for PIN: " - (if (setq entry (assoc key-id epg-user-id-alist)) - (format "Passphrase for %s %s: " key-id (cdr entry)) - (format "Passphrase for %s: " key-id))) - (if (eq key-id 'PIN) - "PIN" - key-id)))) - (when passphrase - (let ((password-cache-expiry mml2015-passphrase-cache-expiry)) - (password-cache-add key-id passphrase)) - (setq mml2015-epg-secret-key-id-list - (cons key-id mml2015-epg-secret-key-id-list)) - (copy-sequence passphrase))))) - -(defun mml2015-epg-find-usable-key (keys usage) - (catch 'found - (while keys - (let ((pointer (epg-key-sub-key-list (car keys)))) - (while pointer - (if (and (memq usage (epg-sub-key-capability (car pointer))) - (not (memq (epg-sub-key-validity (car pointer)) - '(revoked expired)))) - (throw 'found (car keys))) - (setq pointer (cdr pointer)))) - (setq keys (cdr keys))))) +(autoload 'epg-make-context "epg") +(autoload 'epg-context-set-armor "epg") +(autoload 'epg-context-set-textmode "epg") +(autoload 'epg-context-set-signers "epg") +(autoload 'epg-context-result-for "epg") +(autoload 'epg-new-signature-digest-algorithm "epg") +(autoload 'epg-list-keys "epg") +(autoload 'epg-decrypt-string "epg") +(autoload 'epg-verify-string "epg") +(autoload 'epg-sign-string "epg") +(autoload 'epg-encrypt-string "epg") +(autoload 'epg-passphrase-callback-function "epg") +(autoload 'epg-context-set-passphrase-callback "epg") +(autoload 'epg-key-sub-key-list "epg") +(autoload 'epg-sub-key-capability "epg") +(autoload 'epg-sub-key-validity "epg") +(autoload 'epg-sub-key-fingerprint "epg") +(autoload 'epg-signature-key-id "epg") +(autoload 'epg-signature-to-string "epg") +(autoload 'epg-key-user-id-list "epg") +(autoload 'epg-user-id-string "epg") +(autoload 'epg-user-id-validity "epg") +(autoload 'epg-configuration "epg-config") +(autoload 'epg-expand-group "epg-config") +(autoload 'epa-select-keys "epa") + +(autoload 'gnus-create-image "gnus-ems") + +(defun mml2015-epg-key-image (key-id) + "Return the image of a key, if any" + (with-temp-buffer + (mm-set-buffer-multibyte nil) + (let* ((coding-system-for-write 'binary) + (coding-system-for-read 'binary) + (data (shell-command-to-string + (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1" + (shell-quote-argument epg-gpg-program) key-id)))) + (when (> (length data) 0) + (insert (substring data 16)) + (condition-case nil + (gnus-create-image (buffer-string) nil t) + (error)))))) + +(autoload 'gnus-rescale-image "gnus-util") + +(defun mml2015-epg-key-image-to-string (key-id) + "Return a string with the image of a key, if any" + (let ((key-image (mml2015-epg-key-image key-id))) + (if (not key-image) + "" + (condition-case error + (let ((result " ")) + (put-text-property + 1 2 'display + (gnus-rescale-image key-image + (cons mml2015-maximum-key-image-dimension + mml2015-maximum-key-image-dimension)) + result) + result) + (error ""))))) + +(defun mml2015-epg-signature-to-string (signature) + (concat (epg-signature-to-string signature) + (when mml2015-display-key-image + (mml2015-epg-key-image-to-string (epg-signature-key-id signature))))) + +(defun mml2015-epg-verify-result-to-string (verify-result) + (mapconcat #'mml2015-epg-signature-to-string verify-result "\n")) (defun mml2015-epg-decrypt (handle ctl) (catch 'error @@ -1040,18 +834,15 @@ Whether the passphrase is cached at all is controlled by mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (setq context (epg-make-context)) - (if mml2015-cache-passphrase + (if (or mml2015-cache-passphrase mml-secure-cache-passphrase) (epg-context-set-passphrase-callback context - #'mml2015-epg-passphrase-callback)) + (cons 'mml-secure-passphrase-callback 'OpenPGP))) (condition-case error (setq plain (epg-decrypt-string context (mm-get-part child)) - mml2015-epg-secret-key-id-list nil) + mml-secure-secret-key-id-list nil) (error - (while mml2015-epg-secret-key-id-list - (password-cache-remove (car mml2015-epg-secret-key-id-list)) - (setq mml2015-epg-secret-key-id-list - (cdr mml2015-epg-secret-key-id-list))) + (mml-secure-clear-secret-key-id-list) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (if (eq (car error) 'quit) @@ -1071,7 +862,7 @@ Whether the passphrase is cached at all is controlled by (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info (concat "OK\n" - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify)))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK")) @@ -1087,18 +878,15 @@ Whether the passphrase is cached at all is controlled by (let ((inhibit-redisplay t) (context (epg-make-context)) plain) - (if mml2015-cache-passphrase + (if (or mml2015-cache-passphrase mml-secure-cache-passphrase) (epg-context-set-passphrase-callback context - #'mml2015-epg-passphrase-callback)) + (cons 'mml-secure-passphrase-callback 'OpenPGP))) (condition-case error (setq plain (epg-decrypt-string context (buffer-string)) - mml2015-epg-secret-key-id-list nil) + mml-secure-secret-key-id-list nil) (error - (while mml2015-epg-secret-key-id-list - (password-cache-remove (car mml2015-epg-secret-key-id-list)) - (setq mml2015-epg-secret-key-id-list - (cdr mml2015-epg-secret-key-id-list))) + (mml-secure-clear-secret-key-id-list) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (if (eq (car error) 'quit) @@ -1119,7 +907,7 @@ Whether the passphrase is cached at all is controlled by (if (epg-context-result-for context 'verify) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify))))))) (defun mml2015-epg-verify (handle ctl) @@ -1137,7 +925,7 @@ Whether the passphrase is cached at all is controlled by (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) - (setq part (mm-replace-in-string part "\n" "\r\n" t) + (setq part (mm-replace-in-string part "\n" "\r\n") signature (mm-get-part signature) context (epg-make-context)) (condition-case error @@ -1153,7 +941,8 @@ Whether the passphrase is cached at all is controlled by (throw 'error handle))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info - (epg-verify-result-to-string (epg-context-result-for context 'verify))) + (mml2015-epg-verify-result-to-string + (epg-context-result-for context 'verify))) handle))) (defun mml2015-epg-clear-verify () @@ -1176,169 +965,44 @@ Whether the passphrase is cached at all is controlled by (progn (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify))) (delete-region (point-min) (point-max)) (insert (mm-decode-coding-string plain coding-system-for-read))) (mml2015-extract-cleartext-signature)))) (defun mml2015-epg-sign (cont) - (let* ((inhibit-redisplay t) - (context (epg-make-context)) - (boundary (mml-compute-boundary cont)) - signer-key - (signers - (or (message-options-get 'mml2015-epg-signers) - (message-options-set - 'mml2015-epg-signers - (if mml2015-verbose - (epa-select-keys context "\ -Select keys for signing. -If no one is selected, default secret key is used. " - mml2015-signers t) - (if mml2015-signers - (delq nil - (mapcar - (lambda (signer) - (setq signer-key (mml2015-epg-find-usable-key - (epg-list-keys context signer t) - 'sign)) - (unless (or signer-key - (y-or-n-p - (format - "No secret key for %s; skip it? " - signer))) - (error "No secret key for %s" signer)) - signer-key) - mml2015-signers))))))) - signature micalg) - (epg-context-set-armor context t) - (epg-context-set-textmode context t) - (epg-context-set-signers context signers) - (if mml2015-cache-passphrase - (epg-context-set-passphrase-callback - context - #'mml2015-epg-passphrase-callback)) - (condition-case error - (setq signature (epg-sign-string context (buffer-string) t) - mml2015-epg-secret-key-id-list nil) - (error - (while mml2015-epg-secret-key-id-list - (password-cache-remove (car mml2015-epg-secret-key-id-list)) - (setq mml2015-epg-secret-key-id-list - (cdr mml2015-epg-secret-key-id-list))) - (signal (car error) (cdr error)))) - (if (epg-context-result-for context 'sign) - (setq micalg (epg-new-signature-digest-algorithm - (car (epg-context-result-for context 'sign))))) - (goto-char (point-min)) - (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" - boundary)) - (if micalg - (insert (format "\tmicalg=pgp-%s; " - (downcase - (cdr (assq micalg - epg-digest-algorithm-alist)))))) - (insert "protocol=\"application/pgp-signature\"\n") - (insert (format "\n--%s\n" boundary)) - (goto-char (point-max)) - (insert (format "\n--%s\n" boundary)) - (insert "Content-Type: application/pgp-signature\n\n") - (insert signature) + (let ((inhibit-redisplay t) + (boundary (mml-compute-boundary cont))) + ;; Signed data must end with a newline (RFC 3156, 5). (goto-char (point-max)) - (insert (format "--%s--\n" boundary)) - (goto-char (point-max)))) + (unless (bolp) + (insert "\n")) + (let* ((pair (mml-secure-epg-sign 'OpenPGP t)) + (signature (car pair)) + (micalg (cdr pair))) + (goto-char (point-min)) + (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" + boundary)) + (if micalg + (insert (format "\tmicalg=pgp-%s; " + (downcase + (cdr (assq micalg + epg-digest-algorithm-alist)))))) + (insert "protocol=\"application/pgp-signature\"\n") + (insert (format "\n--%s\n" boundary)) + (goto-char (point-max)) + (insert (format "\n--%s\n" boundary)) + (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n") + (insert signature) + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max))))) (defun mml2015-epg-encrypt (cont &optional sign) - (let ((inhibit-redisplay t) - (context (epg-make-context)) - (config (epg-configuration)) - (recipients (message-options-get 'mml2015-epg-recipients)) - cipher signers - (boundary (mml-compute-boundary cont)) - recipient-key signer-key) - (unless recipients - (setq recipients - (apply #'nconc - (mapcar - (lambda (recipient) - (or (epg-expand-group config recipient) - (list (concat "<" recipient ">")))) - (split-string - (or (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+")))) - (when mml2015-encrypt-to-self - (unless mml2015-signers - (error "mml2015-signers not set")) - (setq recipients (nconc recipients mml2015-signers))) - (if mml2015-verbose - (setq recipients - (epa-select-keys context "\ -Select recipients for encryption. -If no one is selected, symmetric encryption will be performed. " - recipients)) - (setq recipients - (delq nil - (mapcar - (lambda (recipient) - (setq recipient-key (mml2015-epg-find-usable-key - (epg-list-keys context recipient) - 'encrypt)) - (unless (or recipient-key - (y-or-n-p - (format "No public key for %s; skip it? " - recipient))) - (error "No public key for %s" recipient)) - recipient-key) - recipients))) - (unless recipients - (error "No recipient specified"))) - (message-options-set 'mml2015-epg-recipients recipients)) - (when sign - (setq signers - (or (message-options-get 'mml2015-epg-signers) - (message-options-set - 'mml2015-epg-signers - (if mml2015-verbose - (epa-select-keys context "\ -Select keys for signing. -If no one is selected, default secret key is used. " - mml2015-signers t) - (if mml2015-signers - (delq nil - (mapcar - (lambda (signer) - (setq signer-key (mml2015-epg-find-usable-key - (epg-list-keys context signer t) - 'sign)) - (unless (or signer-key - (y-or-n-p - (format - "No secret key for %s; skip it? " - signer))) - (error "No secret key for %s" signer)) - signer-key) - mml2015-signers))))))) - (epg-context-set-signers context signers)) - (epg-context-set-armor context t) - (epg-context-set-textmode context t) - (if mml2015-cache-passphrase - (epg-context-set-passphrase-callback - context - #'mml2015-epg-passphrase-callback)) - (condition-case error - (setq cipher - (epg-encrypt-string context (buffer-string) recipients sign - mml2015-always-trust) - mml2015-epg-secret-key-id-list nil) - (error - (while mml2015-epg-secret-key-id-list - (password-cache-remove (car mml2015-epg-secret-key-id-list)) - (setq mml2015-epg-secret-key-id-list - (cdr mml2015-epg-secret-key-id-list))) - (signal (car error) (cdr error)))) + (let* ((inhibit-redisplay t) + (boundary (mml-compute-boundary cont)) + (cipher (mml-secure-epg-encrypt 'OpenPGP cont sign))) (delete-region (point-min) (point-max)) (goto-char (point-min)) (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" @@ -1420,5 +1084,4 @@ If no one is selected, default secret key is used. " (provide 'mml2015) -;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 ;;; mml2015.el ends here