From 785ec6b8049cc63199db3c1a805d9986208245d4 Mon Sep 17 00:00:00 2001 From: ShengHuo ZHU Date: Tue, 7 Nov 2000 18:38:49 +0000 Subject: [PATCH] Add MIME security button. 2000-11-07 14:33:19 ShengHuo ZHU * gnus-art.el (gnus-mime-display-part): Show MIME security button. (gnus-insert-mime-security-button): New function. * mm-decode.el (mm-possibly-verify-or-decrypt): Add security info. * mml2015.el: Add security info when verify or decrypt. * mm-uu.el (mm-uu-pgp-signed-extract): Use multipart. (mm-uu-pgp-encrypted-extract): Ditto. --- lisp/ChangeLog | 9 +++ lisp/gnus-art.el | 75 +++++++++++++++++++ lisp/mm-decode.el | 37 ++++++---- lisp/mm-uu.el | 42 +++++------ lisp/mml2015.el | 182 ++++++++++++++++++++++++++++++---------------- 5 files changed, 245 insertions(+), 100 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6f7220a5b..0846ae145 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2000-11-07 14:33:19 ShengHuo ZHU + + * gnus-art.el (gnus-mime-display-part): Show MIME security button. + (gnus-insert-mime-security-button): New function. + * mm-decode.el (mm-possibly-verify-or-decrypt): Add security info. + * mml2015.el: Add security info when verify or decrypt. + * mm-uu.el (mm-uu-pgp-signed-extract): Use multipart. + (mm-uu-pgp-encrypted-extract): Ditto. + 2000-11-07 08:49:36 ShengHuo ZHU * mm-decode.el (mm-display-parts): New function. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 996866b4d..3436814a7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -3491,10 +3491,12 @@ In no internal viewer is available, use an external viewer." ((equal (car handle) "multipart/signed") (or (memq 'signed gnus-article-wash-types) (push 'signed gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) (gnus-mime-display-mixed (cdr handle))) ((equal (car handle) "multipart/encrypted") (or (memq 'encrypted gnus-article-wash-types) (push 'encrypted gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) (gnus-mime-display-mixed (cdr handle))) (t (gnus-mime-display-mixed (cdr handle))))) @@ -4980,6 +4982,79 @@ For example: (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current)))))))) +(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info") + +(defvar gnus-mime-security-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?i gnus-tmp-info ?s))) + +(defvar gnus-mime-security-button-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map gnus-article-mode-map) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map "\r" 'gnus-article-press-button) + map)) + +(defvar gnus-mime-security-details-buffer nil) + +(defun gnus-mime-security-show-details (handle) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (if details + (progn + (if (gnus-buffer-live-p gnus-mime-security-details-buffer) + (with-current-buffer gnus-mime-security-details-buffer + (erase-buffer) + t) + (setq gnus-mime-security-details-buffer + (gnus-get-buffer-create "*MIME Security Details*"))) + (with-current-buffer gnus-mime-security-details-buffer + (insert details)) + (pop-to-buffer gnus-mime-security-details-buffer)) + (gnus-message 5 "No details.")))) + +(defun gnus-insert-mime-security-button (handle &optional displayed) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (gnus-tmp-type + (concat + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted"))) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + b e) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (gnus-eval-format + gnus-mime-security-button-line-format + gnus-mime-security-button-line-format-alist + `(local-map ,gnus-mime-security-button-map + keymap ,gnus-mime-security-button-map + gnus-callback gnus-mime-security-show-details + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-security-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (if (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: show detail" + (aref gnus-mouse-2 0)))))) + (gnus-ems-redefine) (provide 'gnus-art) diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index b0ff1d83a..9f3e4fc6c 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -994,8 +994,17 @@ If RECURSIVE, search recursively." (setq result (buffer-substring (point-min) (point-max))))))) result)) +(defvar mm-security-handle nil) + +(defsubst mm-set-handle-multipart-parameter (handle parameter value) + ;; HANDLE could be a CTL. + (if handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) + (defun mm-possibly-verify-or-decrypt (parts ctl) (let ((subtype (cadr (split-string (car ctl) "/"))) + (mm-security-handle ctl) ;; (car CTL) is the type. protocol func functest) (cond ((equal subtype "signed") @@ -1024,14 +1033,12 @@ If RECURSIVE, search recursively." (format "Verify signed (%s) part? " (or (nth 2 (assoc protocol mm-verify-function-alist)) (format "protocol=%s" protocol)))))) - (condition-case err - (save-excursion - (if func - (funcall func parts ctl) - (error (format "Unknown sign protocol (%s)" protocol)))) - (error - (unless (y-or-n-p (format "%s, continue? " err)) - (error "Verify failure.")))))) + (save-excursion + (if func + (funcall func parts ctl) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown sign protocol (%s)" protocol)))))) ((equal subtype "encrypted") (unless (setq protocol (mail-content-type-get ctl 'protocol)) ;; The message is broken. @@ -1056,14 +1063,12 @@ If RECURSIVE, search recursively." (format "Decrypt (%s) part? " (or (nth 2 (assoc protocol mm-decrypt-function-alist)) (format "protocol=%s" protocol)))))) - (condition-case err - (save-excursion - (if func - (setq parts (funcall func parts ctl)) - (error (format "Unknown encrypt protocol (%s)" protocol)))) - (error - (unless (y-or-n-p (format "%s, continue? " err)) - (error "Decrypt failure.")))))) + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown encrypt protocol (%s)" protocol)))))) (t nil)) parts)) diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el index 7a7181d1b..bd724c2fc 100644 --- a/lisp/mm-uu.el +++ b/lisp/mm-uu.el @@ -257,23 +257,22 @@ To disable dissecting shar codes, for instance, add (t (y-or-n-p "Verify pgp signed part?"))))) (defun mm-uu-pgp-signed-extract () - (or (memq 'signed gnus-article-wash-types) - (push 'signed gnus-article-wash-types)) - (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (let ((buf (mm-uu-copy-to-buffer start-point end-point)) + (mm-security-handle (list (format "multipart/signed")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/pgp-signature") (with-current-buffer buf - (condition-case err - (funcall (mml2015-clear-verify-function)) - (error - (unless (y-or-n-p (format "%s, continue?" err)) - (kill-buffer buf) - (error "Verify failure.")))) + (funcall (mml2015-clear-verify-function)) (goto-char (point-min)) (if (search-forward "\n\n" nil t) (delete-region (point-min) (point))) (if (re-search-forward mm-uu-pgp-beginning-signature nil t) (delete-region (match-beginning 0) (point-max)))) - (mm-make-handle buf - '("text/plain" (charset . gnus-decoded))))) + (setcdr mm-security-handle + (list + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + mm-security-handle)) (defun mm-uu-pgp-encrypted-test () (and @@ -286,18 +285,17 @@ To disable dissecting shar codes, for instance, add (t (y-or-n-p "Decrypt pgp encrypted part?"))))) (defun mm-uu-pgp-encrypted-extract () - (or (memq 'encrypted gnus-article-wash-types) - (push 'encrypted gnus-article-wash-types)) - (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (let ((buf (mm-uu-copy-to-buffer start-point end-point)) + (mm-security-handle (list (format "multipart/encrypted")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/pgp-encrypted") (with-current-buffer buf - (condition-case err - (funcall (mml2015-clear-decrypt-function)) - (error - (unless (y-or-n-p (format "%s, continue?" err)) - (kill-buffer buf) - (error "Decrypt failure."))))) - (mm-make-handle buf - '("text/plain" (charset . gnus-decoded))))) + (funcall (mml2015-clear-decrypt-function))) + (setcdr mm-security-handle + (list + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + mm-security-handle)) (defun mm-uu-gpg-key-skip-to-last () (let ((point (point)) diff --git a/lisp/mml2015.el b/lisp/mml2015.el index dfd62be40..973d50ffd 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -77,27 +77,49 @@ (defvar mml2015-verify-function 'mailcrypt-verify) (defun mml2015-mailcrypt-decrypt (handle ctl) - (let (child handles result) - (unless (setq child (mm-find-part-by-type - (cdr handle) - "application/octet-stream" nil t)) - (error "Corrupted pgp-encrypted part.")) - (with-temp-buffer - (mm-insert-part child) - (setq result (funcall mml2015-decrypt-function)) - (unless (car result) - (error "Decrypting error.")) - (setq handles (mm-dissect-buffer t))) - (mm-destroy-parts handle) - (if (listp (car handles)) - handles - (list handles)))) + (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 (cadr err)) + 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 "OK") + (if (listp (car handles)) + handles + (list handles))))) (defun mml2015-mailcrypt-clear-decrypt () (let (result) - (setq result (funcall mml2015-decrypt-function)) - (unless (car result) - (error "Decrypting error.")))) + (setq result + (condition-case err + (funcall mml2015-decrypt-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + 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) (upcase @@ -106,31 +128,53 @@ alg))) (defun mml2015-mailcrypt-verify (handle ctl) - (let (part) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mail-content-type-get ctl 'protocol) - "application/pgp-signature") - t)) - (error "Corrupted pgp-signature part.")) - (with-temp-buffer - (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") - (insert (format "Hash: %s\n\n" - (or (mml2015-fix-micalg - (mail-content-type-get ctl 'micalg)) - "SHA1"))) - (insert part "\n") - (goto-char (point-max)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (error "Corrupted pgp-signature part.")) - (mm-insert-part part) - (unless (funcall mml2015-verify-function) - (error "Verify error."))) - handle)) + (catch 'error + (let (part) + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mail-content-type-get 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 + (mail-content-type-get ctl 'micalg)) + "SHA1"))) + (insert part "\n") + (goto-char (point-max)) + (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 + (funcall mml2015-verify-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + 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 () - (unless (funcall mml2015-verify-function) - (error "Verify error."))) + (if (condition-case err + (funcall mml2015-verify-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + 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) @@ -227,7 +271,9 @@ ;; Some wrong with the return value, check plain text buffer. (if (> (point-max) (point-min)) '(t) - (pop-to-buffer mml2015-result-buffer) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (buffer-string mml2015-result-buffer)) nil)))) (defun mml2015-gpg-decrypt (handle ctl) @@ -237,29 +283,41 @@ (defun mml2015-gpg-clear-decrypt () (let (result) (setq result (mml2015-gpg-decrypt-1)) - (unless (car result) - (error "Decrypting error.")))) + (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-verify (handle ctl) - (let (part message signature) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mail-content-type-get ctl 'protocol) - "application/pgp-signature") - t)) - (error "Corrupted pgp-signature part.")) - (with-temp-buffer - (setq message (current-buffer)) - (insert part) + (catch 'error + (let (part message signature) + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mail-content-type-get ctl 'protocol) + "application/pgp-signature") + t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) (with-temp-buffer - (setq signature (current-buffer)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (error "Corrupted pgp-signature part.")) - (mm-insert-part part) - (unless (gpg-verify message signature mml2015-result-buffer) - (pop-to-buffer mml2015-result-buffer) - (error "Verify error."))))) - handle) + (setq message (current-buffer)) + (insert part) + (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 (gpg-verify message signature mml2015-result-buffer) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (buffer-string mml2015-result-buffer)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (throw 'error handle)))) + handle))) (defun mml2015-gpg-sign (cont) (let ((boundary -- 2.25.1