diff options
Diffstat (limited to 'lisp/gnus/mml2015.el')
| -rw-r--r-- | lisp/gnus/mml2015.el | 489 |
1 files changed, 476 insertions, 13 deletions
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 4edf595faae..1760e4615ce 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -34,13 +34,23 @@ (require 'mm-decode) (require 'mm-util) (require 'mml) +(require 'mml-sec) (defvar mc-pgp-always-sign) (defvar mml2015-use (or + (condition-case nil + (progn + (require 'epg-config) + (epg-check-configuration (epg-configuration)) + 'epg) + (error)) (progn (ignore-errors - (require 'pgg)) + ;; Avoid the "Recursive load suspected" error + ;; in Emacs 21.1. + (let ((recursive-load-depth-limit 100)) + (require 'pgg))) (and (fboundp 'pgg-sign-region) 'pgg)) (progn @@ -54,7 +64,8 @@ (fboundp 'mc-sign-generic) (fboundp 'mc-cleanup-recipient-headers) 'mailcrypt))) - "The package used for PGP/MIME.") + "The package used for PGP/MIME. +Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") ;; Something is not RFC2015. (defvar mml2015-function-alist @@ -75,7 +86,13 @@ mml2015-pgg-verify mml2015-pgg-decrypt mml2015-pgg-clear-verify - mml2015-pgg-clear-decrypt)) + 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) @@ -92,6 +109,60 @@ :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) + +(defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml2015-cache-passphrase'." + :group 'mime-security + :type 'integer) + +(defcustom mml2015-signers nil + "A list of your own key ID which will be used to sign a message." + :group 'mime-security + :type '(repeat (string :tag "Key ID"))) + +(defcustom mml2015-encrypt-to-self nil + "If t, add your own key ID to recipient list when encryption." + :group 'mime-security + :type 'boolean) + +(defcustom mml2015-always-trust t + "If t, GnuPG skip key validation on encryption." + :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. +(defun mml2015-extract-cleartext-signature () + (goto-char (point-min)) + (forward-line) + ;; We need to be careful not to strip beyond the armor headers. + ;; Previously, an attacker could replace the text inside our + ;; markup with trailing garbage by injecting whitespace into the + ;; message. + (while (looking-at "Hash:") ; The only header allowed in cleartext + (forward-line)) ; signatures according to RFC2440. + (when (looking-at "[\t ]*$") + (forward-line)) + (delete-region (point-min) (point)) + (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t) + (delete-region (match-beginning 0) (point-max))) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (replace-match "" t t) + (forward-line 1))) + ;;; mailcrypt wrapper (eval-and-compile @@ -278,7 +349,8 @@ (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) + mm-security-handle 'gnus-info "Failed"))) + (mml2015-extract-cleartext-signature)) (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) @@ -475,9 +547,8 @@ (with-temp-buffer (setq message (current-buffer)) (insert part) - ;; Convert <LF> to <CR><LF> in verify mode. Sign and - ;; clearsign use --textmode. The conversion is not necessary. - ;; In clearverify, the conversion is not necessary either. + ;; Convert <LF> to <CR><LF> in signed text. If --textmode is + ;; specified when signing, the conversion is not necessary. (goto-char (point-min)) (end-of-line) (while (not (eobp)) @@ -545,7 +616,8 @@ (with-current-buffer mml2015-result-buffer (mml2015-gpg-extract-signature-details))) (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed"))) + mm-security-handle 'gnus-info "Failed")) + (mml2015-extract-cleartext-signature)) (defun mml2015-gpg-sign (cont) (let ((boundary (mml-compute-boundary cont)) @@ -734,9 +806,8 @@ handle) (with-temp-buffer (insert part) - ;; Convert <LF> to <CR><LF> in verify mode. Sign and - ;; clearsign use --textmode. The conversion is not necessary. - ;; In clearverify, the conversion is not necessary either. + ;; Convert <LF> to <CR><LF> in signed text. If --textmode is + ;; specified when signing, the conversion is not necessary. (goto-char (point-min)) (end-of-line) (while (not (eobp)) @@ -809,7 +880,8 @@ (with-current-buffer pgg-errors-buffer (mml2015-gpg-extract-signature-details))) (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) + mm-security-handle 'gnus-info "Failed"))) + (mml2015-extract-cleartext-signature)) (defun mml2015-pgg-sign (cont) (let ((pgg-errors-buffer mml2015-result-buffer) @@ -871,6 +943,397 @@ (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) +;;; epg wrapper + +(eval-and-compile + (autoload 'epg-make-context "epg")) + +(eval-when-compile + (defvar epg-user-id-alist) + (defvar epg-digest-algorithm-alist) + (defvar inhibit-redisplay) + (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")) + +(eval-when-compile + (defvar password-cache-expiry) + (autoload 'password-read "password") + (autoload 'password-cache-add "password") + (autoload 'password-cache-remove "password")) + +(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))))) + +(defun mml2015-epg-decrypt (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain child handles result decrypt-status) + (unless (setq child (mm-find-part-by-type + (cdr handle) + "application/octet-stream" nil t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (setq context (epg-make-context)) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq plain (epg-decrypt-string context (mm-get-part child)) + 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))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))) + (throw 'error handle))) + (with-temp-buffer + (insert plain) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)) + (setq handles (mm-dissect-buffer t)) + (mm-destroy-parts handle) + (if (epg-context-result-for context 'verify) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (concat "OK\n" + (epg-verify-result-to-string + (epg-context-result-for context 'verify)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK")) + (if (stringp (car handles)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (mm-handle-multipart-ctl-parameter handles 'gnus-details)))) + (if (listp (car handles)) + handles + (list handles))))) + +(defun mml2015-epg-clear-decrypt () + (let ((inhibit-redisplay t) + (context (epg-make-context)) + plain) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq plain (epg-decrypt-string context (buffer-string)) + 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))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))))) + (when plain + (erase-buffer) + ;; Treat data which epg returns as a unibyte string. + (mm-disable-multibyte) + (insert plain) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (if (epg-context-result-for context 'verify) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (epg-verify-result-to-string + (epg-context-result-for context 'verify))))))) + +(defun mml2015-epg-verify (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain signature-file part signature) + (when (or (null (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter + ctl 'protocol) + "application/pgp-signature") + t))) + (null (setq signature (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)) + (setq part (mm-replace-in-string part "\n" "\r\n" t) + signature (mm-get-part signature) + context (epg-make-context)) + (condition-case error + (setq plain (epg-verify-string context signature part)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))) + (throw 'error handle))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (epg-verify-result-to-string (epg-context-result-for context 'verify))) + handle))) + +(defun mml2015-epg-clear-verify () + (let ((inhibit-redisplay t) + (context (epg-make-context)) + (signature (mm-encode-coding-string (buffer-string) + coding-system-for-write)) + plain) + (condition-case error + (setq plain (epg-verify-string context signature)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))))) + (if plain + (progn + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (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 + (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) + (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 + (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 + (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)))) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (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 cipher) + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max)))) + ;;; General wrapper (defun mml2015-clean-buffer () @@ -879,7 +1342,7 @@ (erase-buffer) t) (setq mml2015-result-buffer - (gnus-get-buffer-create "*MML2015 Result*")) + (gnus-get-buffer-create " *MML2015 Result*")) nil)) (defsubst mml2015-clear-decrypt-function () |