Mercurial > emacs
view lisp/gnus/mml2015.el @ 98660:90b078ed2dc4
(grep-mode-tool-bar-map): Check if tool-bar-map has been initialized
before setting it up.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sun, 12 Oct 2008 13:46:13 +0000 |
parents | 645fb33380d6 |
children | a9dc0e7c3f2b |
line wrap: on
line source
;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, ;; 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> ;; 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 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. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; RFC 2015 is updated by RFC 3156, this file should be compatible ;; with both. ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mm-decode) (require 'mm-util) (require 'mml) (require 'mml-sec) (defvar mc-pgp-always-sign) (declare-function epg-check-configuration "ext:epg-config" (config &optional minimum-version)) (declare-function epg-configuration "ext:epg-config" ()) (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)) (progn (ignore-errors (require 'gpg)) (and (fboundp 'gpg-sign-detached) 'gpg)) (progn (ignore-errors (load "mc-toplev")) (and (fboundp 'mc-encrypt-generic) (fboundp 'mc-sign-generic) (fboundp 'mc-cleanup-recipient-headers) 'mailcrypt))) "The package used for PGP/MIME. Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") ;; Something is not RFC2015. (defvar mml2015-function-alist '((mailcrypt mml2015-mailcrypt-sign mml2015-mailcrypt-encrypt mml2015-mailcrypt-verify 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)) "Alist of PGP/MIME functions.") (defvar mml2015-result-buffer nil) (defcustom mml2015-unabbrev-trust-alist '(("TRUST_UNDEFINED" . nil) ("TRUST_NEVER" . nil) ("TRUST_MARGINAL" . t) ("TRUST_FULLY" . t) ("TRUST_ULTIMATE" . t)) "Map GnuPG trust output values to a boolean saying if you trust the key." :version "22.1" :group 'mime-security :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 () ;; Daiki Ueno in ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still ;; believe that the right way is to use the plaintext output from GnuPG as ;; it is, and mml2015-extract-cleartext-signature is just a kludge for ;; misdesigned libraries like PGG, which have no ability to do that. So, I ;; think it should not have descriptive documentation.'' ;; ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it ;; correctly. ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109 (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 (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) (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) (defun mml2015-format-error (err) (if (stringp (cadr err)) (cadr err) (format "%S" (cdr err)))) (defun mml2015-mailcrypt-decrypt (handle ctl) (catch 'error (let (child handles result) (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)) (with-temp-buffer (mm-insert-part child) (setq result (condition-case err (funcall mml2015-decrypt-function) (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))) (unless (car result) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (throw 'error handle)) (setq handles (mm-dissect-buffer t))) (mm-destroy-parts handle) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info (concat "OK" (let ((sig (with-current-buffer mml2015-result-buffer (mml2015-gpg-extract-signature-details)))) (concat ", Signer: " sig)))) (if (listp (car handles)) handles (list handles))))) (defun mml2015-mailcrypt-clear-decrypt () (let (result) (setq result (condition-case err (funcall mml2015-decrypt-function) (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))) (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-fix-micalg (alg) (and alg ;; Mutt/1.2.5i has seen sending micalg=php-sha1 (upcase (if (string-match "^p[gh]p-" alg) (substring alg (match-end 0)) alg)))) (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) (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 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") (insert (format "Hash: %s\n\n" (or (mml2015-fix-micalg (mm-handle-multipart-ctl-parameter ctl 'micalg)) "SHA1"))) (save-restriction (narrow-to-region (point) (point)) (insert part "\n") (goto-char (point-min)) (while (not (eobp)) (if (looking-at "^-") (insert "- ")) (forward-line))) (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)) (save-restriction (narrow-to-region (point) (point)) (mm-insert-part part) (goto-char (point-min)) (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t) (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) (unless (condition-case err (prog1 (funcall mml2015-verify-function) (if (get-buffer " *mailcrypt stderr temp") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (with-current-buffer " *mailcrypt stderr temp" (buffer-string)))) (if (get-buffer " *mailcrypt stdout temp") (kill-buffer " *mailcrypt stdout temp")) (if (get-buffer " *mailcrypt stderr temp") (kill-buffer " *mailcrypt stderr temp")) (if (get-buffer " *mailcrypt status temp") (kill-buffer " *mailcrypt status temp")) (if (get-buffer mc-gpg-debug-buffer) (kill-buffer mc-gpg-debug-buffer))) (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 "Failed") (throw 'error handle)))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") handle))) (defun mml2015-mailcrypt-clear-verify () (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) (if (condition-case err (prog1 (funcall mml2015-verify-function) (if (get-buffer " *mailcrypt stderr temp") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (with-current-buffer " *mailcrypt stderr temp" (buffer-string)))) (if (get-buffer " *mailcrypt stdout temp") (kill-buffer " *mailcrypt stdout temp")) (if (get-buffer " *mailcrypt stderr temp") (kill-buffer " *mailcrypt stderr temp")) (if (get-buffer " *mailcrypt status temp") (kill-buffer " *mailcrypt status temp")) (if (get-buffer mc-gpg-debug-buffer) (kill-buffer mc-gpg-debug-buffer))) (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 "OK") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed"))) (mml2015-extract-cleartext-signature)) (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) nil nil nil nil) (let ((boundary (mml-compute-boundary cont)) hash point) (goto-char (point-min)) (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t) (error "Cannot find signed begin line")) (goto-char (match-beginning 0)) (forward-line 1) (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)") (error "Cannot not find PGP hash")) (setq hash (match-string 1)) (unless (re-search-forward "^$" nil t) (error "Cannot not find PGP message")) (forward-line 1) (delete-region (point-min) (point)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" boundary)) (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n" (downcase hash))) (insert (format "\n--%s\n" boundary)) (setq point (point)) (goto-char (point-max)) (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t) (error "Cannot find signature part")) (replace-match "-----END PGP MESSAGE-----" t t) (goto-char (match-beginning 0)) (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$" nil t) (error "Cannot find signature part")) (replace-match "-----BEGIN PGP MESSAGE-----" t t) (goto-char (match-beginning 0)) (save-restriction (narrow-to-region point (point)) (goto-char point) (while (re-search-forward "^- -" nil t) (replace-match "-" t t)) (goto-char (point-max))) (insert (format "--%s\n" boundary)) (insert "Content-Type: application/pgp-signature\n\n") (goto-char (point-max)) (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) ;; We require mm-decode, which requires mm-bodies, which autoloads ;; message-options-get (!). (declare-function message-options-set "message" (symbol value)) (defun mml2015-mailcrypt-encrypt (cont &optional sign) (let ((mc-pgp-always-sign (or mc-pgp-always-sign sign (eq t (or (message-options-get 'message-sign-encrypt) (message-options-set 'message-sign-encrypt (or (y-or-n-p "Sign the message? ") 'not)))) 'never))) (mm-with-unibyte-current-buffer (mc-encrypt-generic (or (message-options-get 'message-recipients) (message-options-set 'message-recipients (mc-cleanup-recipient-headers (read-string "Recipients: ")))) nil nil nil (message-options-get 'message-sender)))) (goto-char (point-min)) (unless (looking-at "-----BEGIN PGP MESSAGE-----") (error "Fail to encrypt the message")) (let ((boundary (mml-compute-boundary cont))) (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") (goto-char (point-max)) (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) ;;; gpg wrapper (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 <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)) (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) (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 (let ((pgg-errors-buffer mml2015-result-buffer) 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)) (with-temp-buffer (mm-insert-part child) (if (condition-case err (prog1 (pgg-decrypt-region (point-min) (point-max)) (setq decrypt-status (with-current-buffer mml2015-result-buffer (buffer-string))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details decrypt-status)) (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)) (with-current-buffer pgg-output-buffer (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) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (concat decrypt-status (when (stringp (car handles)) "\n" (mm-handle-multipart-ctl-parameter handles 'gnus-details)))) (if (listp (car handles)) handles (list handles))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (throw 'error handle)))))) (defun mml2015-pgg-clear-decrypt () (let ((pgg-errors-buffer mml2015-result-buffer)) (if (prog1 (pgg-decrypt-region (point-min) (point-max)) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (with-current-buffer mml2015-result-buffer (buffer-string)))) (progn (erase-buffer) ;; Treat data which pgg returns as a unibyte string. (mm-disable-multibyte) (insert-buffer-substring pgg-output-buffer) (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")) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed")))) (defun mml2015-pgg-verify (handle ctl) (let ((pgg-errors-buffer mml2015-result-buffer) signature-file part signature) (if (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)))) (progn (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") handle) (with-temp-buffer (insert part) ;; 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)) (unless (eq (char-before) ?\r) (insert "\r")) (forward-line) (end-of-line)) (with-temp-file (setq signature-file (mm-make-temp-file "pgg")) (mm-insert-part signature)) (if (condition-case err (prog1 (pgg-verify-region (point-min) (point-max) signature-file t) (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-details (concat (with-current-buffer pgg-output-buffer (buffer-string)) (with-current-buffer pgg-errors-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)) (progn (delete-file signature-file) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info (with-current-buffer pgg-errors-buffer (mml2015-gpg-extract-signature-details)))) (delete-file signature-file) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed"))))) handle) (defun mml2015-pgg-clear-verify () (let ((pgg-errors-buffer mml2015-result-buffer) (text (buffer-string)) (coding-system buffer-file-coding-system)) (if (condition-case err (prog1 (mm-with-unibyte-buffer (insert (mm-encode-coding-string text coding-system)) (pgg-verify-region (point-min) (point-max) nil t)) (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-details (concat (with-current-buffer pgg-output-buffer (buffer-string)) (with-current-buffer pgg-errors-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 pgg-errors-buffer (mml2015-gpg-extract-signature-details))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed"))) (mml2015-extract-cleartext-signature)) (defun mml2015-pgg-sign (cont) (let ((pgg-errors-buffer mml2015-result-buffer) (boundary (mml-compute-boundary cont)) (pgg-default-user-id (or (message-options-get 'mml-sender) pgg-default-user-id)) (pgg-text-mode t) entry) (unless (pgg-sign-region (point-min) (point-max)) (pop-to-buffer mml2015-result-buffer) (error "Sign error")) (goto-char (point-min)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" boundary)) (if (setq entry (assq 2 (pgg-parse-armor (with-current-buffer pgg-output-buffer (buffer-string))))) (setq entry (assq 'hash-algorithm (cdr entry)))) (insert (format "\tmicalg=%s; " (if (cdr entry) (downcase (format "pgp-%s" (cdr entry))) "pgp-sha1"))) (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-buffer-substring pgg-output-buffer) (goto-char (point-max)) (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) (defun mml2015-pgg-encrypt (cont &optional sign) (let ((pgg-errors-buffer mml2015-result-buffer) (pgg-text-mode t) (boundary (mml-compute-boundary cont))) (unless (pgg-encrypt-region (point-min) (point-max) (split-string (or (message-options-get 'message-recipients) (message-options-set 'message-recipients (read-string "Recipients: "))) "[ \f\t\n\r\v,]+") sign) (pop-to-buffer mml2015-result-buffer) (error "Encrypt 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-buffer-substring pgg-output-buffer) (goto-char (point-max)) (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) ;;; epg wrapper (defvar epg-user-id-alist) (defvar epg-digest-algorithm-alist) (defvar inhibit-redisplay) (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* ((password-cache-key-id (if (eq key-id 'PIN) "PIN" key-id)) 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))) password-cache-key-id))) (when passphrase (let ((password-cache-expiry mml2015-passphrase-cache-expiry)) (password-cache-add password-cache-key-id passphrase)) (setq mml2015-epg-secret-key-id-list (cons password-cache-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 (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) (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)))) (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 (autoload 'gnus-buffer-live-p "gnus-util") (autoload 'gnus-get-buffer-create "gnus") (defun mml2015-clean-buffer () (if (gnus-buffer-live-p mml2015-result-buffer) (with-current-buffer mml2015-result-buffer (erase-buffer) t) (setq mml2015-result-buffer (gnus-get-buffer-create " *MML2015 Result*")) nil)) (defsubst mml2015-clear-decrypt-function () (nth 6 (assq mml2015-use mml2015-function-alist))) (defsubst mml2015-clear-verify-function () (nth 5 (assq mml2015-use mml2015-function-alist))) ;;;###autoload (defun mml2015-decrypt (handle ctl) (mml2015-clean-buffer) (let ((func (nth 4 (assq mml2015-use mml2015-function-alist)))) (if func (funcall func handle ctl) handle))) ;;;###autoload (defun mml2015-decrypt-test (handle ctl) mml2015-use) ;;;###autoload (defun mml2015-verify (handle ctl) (mml2015-clean-buffer) (let ((func (nth 3 (assq mml2015-use mml2015-function-alist)))) (if func (funcall func handle ctl) handle))) ;;;###autoload (defun mml2015-verify-test (handle ctl) mml2015-use) ;;;###autoload (defun mml2015-encrypt (cont &optional sign) (mml2015-clean-buffer) (let ((func (nth 2 (assq mml2015-use mml2015-function-alist)))) (if func (funcall func cont sign) (error "Cannot find encrypt function")))) ;;;###autoload (defun mml2015-sign (cont) (mml2015-clean-buffer) (let ((func (nth 1 (assq mml2015-use mml2015-function-alist)))) (if func (funcall func cont) (error "Cannot find sign function")))) ;;;###autoload (defun mml2015-self-encrypt () (mml2015-encrypt nil)) (provide 'mml2015) ;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 ;;; mml2015.el ends here