X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml-smime.el;h=2eec91961b77542b76229d5d5ce60452a1b50535;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=835516ab960b969e2074d71bbbfdbd7f386a29d2;hpb=2cc5659442ce551b395b9aeebe213947e415ac6d;p=elisp%2Fgnus.git- diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el index 835516a..2eec919 100644 --- a/lisp/mml-smime.el +++ b/lisp/mml-smime.el @@ -1,5 +1,5 @@ ;;; mml-smime.el --- S/MIME support for MML -;; Copyright (c) 2000 Free Software Foundation, Inc. +;; Copyright (c) 2000, 2001 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: Gnus, MIME, S/MIME, MML @@ -29,7 +29,11 @@ (require 'mm-decode) (defun mml-smime-sign (cont) - (smime-sign-buffer (cdr (assq 'keyfile cont)))) + (when (null smime-keys) + (customize-variable 'smime-keys) + (error "No S/MIME keys configured, use customize to add your key")) + (smime-sign-buffer (cdr (assq 'keyfile cont))) + (goto-char (point-max))) (defun mml-smime-encrypt (cont) (let (certnames certfiles tmp file tmpfiles) @@ -41,7 +45,8 @@ (if (not (and (not (file-exists-p tmp)) (get-buffer tmp))) (push tmp certfiles) - (setq file (make-temp-name mm-tmp-directory)) + (setq file (mm-make-temp-file (expand-file-name "mml." + mm-tmp-directory))) (with-current-buffer tmp (write-region (point-min) (point-max) file)) (push file certfiles) @@ -53,7 +58,8 @@ t) (while (setq tmp (pop tmpfiles)) (delete-file tmp)) - nil))) + nil)) + (goto-char (point-max))) (defun mml-smime-sign-query () ;; query information (what certificate) from user when MML tag is @@ -74,7 +80,7 @@ (smime-get-key-by-email (completing-read "Sign this part with what signature? " smime-keys nil nil - (and (listp (car-safe smime-keys)) + (and (listp (car-safe smime-keys)) (caar smime-keys)))))))) (defun mml-smime-get-file-cert () @@ -90,7 +96,7 @@ (while (not result) (setq who (read-from-minibuffer (format "%sLookup certificate for: " (or bad "")) - (cadr (funcall gnus-extract-address-components + (cadr (funcall gnus-extract-address-components (or (save-excursion (save-restriction (message-narrow-to-headers) @@ -107,8 +113,9 @@ ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) - (ecase (read (gnus-completing-read "dns" "Fetch certificate from" - '(("dns") ("file")) nil t)) + (ecase (read (gnus-completing-read-with-default + "dns" "Fetch certificate from" + '(("dns") ("file")) nil t)) (dns (setq certs (append certs (mml-smime-get-dns-cert)))) (file (setq certs (append certs @@ -121,28 +128,30 @@ (insert-buffer (mm-handle-multipart-original-buffer ctl)) (goto-char (point-min)) (insert (format "Content-Type: %s; " (mm-handle-media-type ctl))) - (insert (format "protocol=\"%s\"; " + (insert (format "protocol=\"%s\"; " (mm-handle-multipart-ctl-parameter ctl 'protocol))) - (insert (format "micalg=\"%s\"; " + (insert (format "micalg=\"%s\"; " (mm-handle-multipart-ctl-parameter ctl 'micalg))) (insert (format "boundary=\"%s\"\n\n" (mm-handle-multipart-ctl-parameter ctl 'boundary))) (when (get-buffer smime-details-buffer) (kill-buffer smime-details-buffer)) (let ((buf (current-buffer)) - (good-signature (smime-verify-buffer)) + (good-signature (smime-noverify-buffer)) + (good-certificate (and (or smime-CA-file smime-CA-directory) + (smime-verify-buffer))) addresses openssl-output) (setq openssl-output (with-current-buffer smime-details-buffer (buffer-string))) (if (not good-signature) (progn ;; we couldn't verify message, fail with openssl output as message - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (concat "OpenSSL failed to verify message:\n" - "---------------------------------\n" + mm-security-handle 'gnus-details + (concat "OpenSSL failed to verify message integrity:\n" + "-------------------------------------------\n" openssl-output))) ;; verify mail addresses in mail against those in certificate (when (and (smime-pkcs7-region (point-min) (point-max)) @@ -151,24 +160,28 @@ (insert-buffer-substring buf) (goto-char (point-min)) (while (re-search-forward "-----END CERTIFICATE-----" nil t) - (smime-pkcs7-email-region (point-min) (point)) - (setq addresses (append (smime-buffer-as-string-region - (point-min) (point)) addresses)) - (delete-region (point-min) (point))))) - (if (not (member mm-security-from addresses)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Sender forged") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK")) + (when (smime-pkcs7-email-region (point-min) (point)) + (setq addresses (append (smime-buffer-as-string-region + (point-min) (point)) addresses))) + (delete-region (point-min) (point))) + (setq addresses (mapcar 'downcase addresses)))) + (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Sender address forged") + (if good-certificate + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Ok (sender authenticated)") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Ok (sender not trusted)"))) (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (concat "Sender clamed to be: " mm-security-from "\n" + mm-security-handle 'gnus-details + (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n" (if addresses - (concat "Addresses in certificate: " + (concat "Addresses in certificate: " (mapconcat 'identity addresses ", ")) - "No addresses found in certificate.") - "\n" "\n" - "OpenSSL output:\n" + "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)") + "\n" "\n" + "OpenSSL output:\n" "---------------\n" openssl-output "\n" "Certificate(s) inside S/MIME signature:\n" "---------------------------------------\n"