;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
-;; Copyright (C) 2000, 2001 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))
+(eval-when-compile (require 'gnus-clfns))
(require 'mm-decode)
(defvar mml2015-use (or
(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)
(funcall mml2015-decrypt-function)
(error
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ mm-security-handle 'gnus-details (mml2015-format-error err))
nil)
(quit
(mm-set-handle-multipart-parameter
(setq handles (mm-dissect-buffer t)))
(mm-destroy-parts handle)
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "OK")
+ 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)))))
(funcall mml2015-decrypt-function)
(error
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ mm-security-handle 'gnus-details (mml2015-format-error err))
nil)
(quit
(mm-set-handle-multipart-parameter
(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))))
(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)))
+ (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))
+ (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 "OK")
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Failed")))
+ mm-security-handle 'gnus-info "Failed"))))
(defun mml2015-mailcrypt-sign (cont)
(mc-sign-generic (message-options-get 'message-sender)
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?$"
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
(insert (format "--%s--\n" boundary))
(goto-char (point-max))))
-(defun mml2015-mailcrypt-encrypt (cont)
+(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
(mc-encrypt-generic
(or (message-options-get 'message-recipients)
(message-options-set 'message-recipients
- (mc-cleanup-recipient-headers
- (read-string "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."))
+ (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"
(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 ()
(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))
(mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Failed"))))
-(defun mml2015-gpg-extract-from ()
+(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 (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t)
- (match-string 1)
- "From unknown user"))
+ (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: "
+ (mml2015-gpg-pretty-print-fpr fprint)))
+ (when expired
+ (format "\nWARNING: Signature from expired key (%s)"
+ (car signer)))))
+ (t
+ "From unknown user")))
+ (if (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t)
+ (match-string 1)
+ "From unknown user")))
(defun mml2015-gpg-verify (handle ctl)
(catch 'error
- (let (part message signature)
+ (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)
(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.
+ (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
(buffer-string))))
(error
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ 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))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Failed")
+ (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-from))))
+ mm-security-handle 'gnus-info
+ (with-current-buffer mml2015-result-buffer
+ (mml2015-gpg-extract-signature-details))))
handle)))
(defun mml2015-gpg-clear-verify ()
(buffer-string))))
(error
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (cadr err))
+ 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-from)))
+ 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")))
t t) ; armor & textmode
(unless (> (point-max) (point-min))
(pop-to-buffer mml2015-result-buffer)
- (error "Sign error.")))
+ (error "Sign error")))
(goto-char (point-min))
(while (re-search-forward "\r+$" nil t)
(replace-match "" t t))
(insert (format "--%s--\n" boundary))
(goto-char (point-max)))))
-(defun mml2015-gpg-encrypt (cont)
+(defun mml2015-gpg-encrypt (cont &optional sign)
(let ((boundary
(funcall mml-boundary-function (incf mml-multipart-number)))
(text (current-buffer))
cipher)
(mm-with-unibyte-current-buffer-mule4
(with-temp-buffer
- (unless (gpg-sign-encrypt
- 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.")))
+ ;; 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))
mml2015-use)
;;;###autoload
-(defun mml2015-encrypt (cont)
+(defun mml2015-encrypt (cont &optional sign)
(mml2015-clean-buffer)
(let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
(if func
- (funcall func cont)
- (error "Cannot find encrypt function."))))
+ (funcall func cont sign)
+ (error "Cannot find encrypt function"))))
;;;###autoload
(defun mml2015-sign (cont)
(let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
(if func
(funcall func cont)
- (error "Cannot find sign function."))))
+ (error "Cannot find sign function"))))
;;;###autoload
(defun mml2015-self-encrypt ()
projects / elisp / gnus.git- / blobdiff