;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
-;; Copyright (C) 2000 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: PGP MIME MML
;;; Commentary:
+;; RFC 2015 is updated by RFC 3156, this file should be compatible
+;; with both.
+
;;; Code:
(eval-when-compile (require 'cl))
(require 'mm-decode)
-(defvar mml2015-use (or
+(defvar mml2015-use (or
(progn
(ignore-errors
(require 'gpg))
mml2015-mailcrypt-verify
mml2015-mailcrypt-decrypt
mml2015-mailcrypt-clear-verify
- mml2015-mailcrypt-clear-decrypt)
+ mml2015-mailcrypt-clear-decrypt)
(gpg mml2015-gpg-sign
mml2015-gpg-encrypt
mml2015-gpg-verify
(defvar mml2015-result-buffer nil)
+(defvar mml2015-trust-boundaries-alist
+ '((trust-undefined . nil)
+ (trust-none . nil)
+ (trust-marginal . t)
+ (trust-full . t)
+ (trust-ultimate . t))
+ "Trust boundaries for a signer's GnuPG key.
+This alist contains pairs of the form (trust-symbol . boolean), with
+symbols that are contained in `gpg-unabbrev-trust-alist'. The boolean
+specifies whether the given trust value is good enough to be trusted
+by you.")
+
;;; mailcrypt wrapper
(eval-and-compile
(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)
+ (unless (setq child (mm-find-part-by-type
+ (cdr handle)
"application/octet-stream" nil t))
- (mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Corrupted")
(throw 'error handle))
(with-temp-buffer
(mm-insert-part child)
- (setq result
+ (setq result
(condition-case err
(funcall mml2015-decrypt-function)
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ (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.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
nil)))
(unless (car result)
- (mm-set-handle-multipart-parameter
+ (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 "OK")
+ (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
+ (setq result
(condition-case err
(funcall mml2015-decrypt-function)
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ (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.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
nil)))
(if (car result)
- (mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "OK")
- (mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Failed"))))
(defun mml2015-fix-micalg (alg)
(and alg
- (upcase (if (string-match "^pgp-" 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
+ (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-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"
+ (insert (format "Hash: %s\n\n"
(or (mml2015-fix-micalg
- (mm-handle-multipart-ctl-parameter
+ (mm-handle-multipart-ctl-parameter
ctl 'micalg))
"SHA1")))
(save-restriction
(if (looking-at "^-")
(insert "- "))
(forward-line)))
- (unless (setq part (mm-find-part-by-type
+ (unless (setq part (mm-find-part-by-type
(cdr handle) "application/pgp-signature" nil t))
- (mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Corrupted")
(throw 'error handle))
(save-restriction
(replace-match "-----BEGIN PGP SIGNATURE-----" t t))
(if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
(replace-match "-----END PGP SIGNATURE-----" t t)))
- (unless (condition-case err
- (funcall mml2015-verify-function)
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr 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
+ (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 ()
- (if (condition-case err
- (funcall mml2015-verify-function)
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr 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")))
+ (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"))))
(defun mml2015-mailcrypt-sign (cont)
(mc-sign-generic (message-options-get 'message-sender)
nil nil nil nil)
- (let ((boundary
+ (let ((boundary
(funcall mml-boundary-function (incf mml-multipart-number)))
hash point)
(goto-char (point-min))
(unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
- (error "Cannot find signed begin line." ))
+ (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." ))
+ (error "Cannot not find PGP hash"))
(setq hash (match-string 1))
(unless (re-search-forward "^$" nil t)
- (error "Cannot not find PGP message." ))
+ (error "Cannot not find PGP message"))
(forward-line 1)
(delete-region (point-min) (point))
(insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
(setq point (point))
(goto-char (point-max))
(unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
- (error "Cannot find signature part." ))
+ (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?$"
+ (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
nil t)
- (error "Cannot find signature part." ))
+ (error "Cannot find signature part"))
(replace-match "-----BEGIN PGP MESSAGE-----" t t)
(goto-char (match-beginning 0))
(save-restriction
(let ((mc-pgp-always-sign
(or mc-pgp-always-sign
(eq t (or (message-options-get 'message-sign-encrypt)
- (message-options-set
+ (message-options-set
'message-sign-encrypt
(or (y-or-n-p "Sign the message? ")
'not))))
'never)))
(mm-with-unibyte-current-buffer-mule4
- (mc-encrypt-generic
+ (mc-encrypt-generic
(or (message-options-get 'message-recipients)
(message-options-set 'message-recipients
- (mc-cleanup-recipient-headers
+ (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
+ (error "Fail to encrypt the message"))
+ (let ((boundary
(funcall mml-boundary-function (incf mml-multipart-number))))
(insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
boundary))
(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 ()
(let ((cipher (current-buffer)) plain result)
(if (with-temp-buffer
(prog1
- (gpg-decrypt cipher (setq plain (current-buffer))
+ (gpg-decrypt cipher (setq plain (current-buffer))
mml2015-result-buffer nil)
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details
+ (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 plain)))
+ (insert-buffer 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))
(let (result)
(setq result (mml2015-gpg-decrypt-1))
(if (car result)
- (mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "OK")
- (mm-set-handle-multipart-parameter
+ (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))
+ (if (boundp 'gpg-unabbrev-trust-alist)
+ (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 (cdr (assoc trust gpg-unabbrev-trust-alist))
+ mml2015-trust-boundaries-alist))))
+ (cond ((and signer fprint)
+ (concat (cdr signer)
+ (unless trust-good-enough-p
+ (concat "\nUntrusted, Fingerprint: "
+ &
projects / gnus / blobdiff