X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml-smime.el;h=2eec91961b77542b76229d5d5ce60452a1b50535;hb=b3b2cc0f4f2109fd7eeba0582be0d336c3a190c2;hp=10d815b37a39d3df40adfb20b3a9dd45e8f70c40;hpb=a039f18ac96bdce5a0fa2c1b5b322270975de413;p=gnus diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el index 10d815b37..2eec91961 100644 --- a/lisp/mml-smime.el +++ b/lisp/mml-smime.el @@ -1,8 +1,8 @@ ;;; 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, SMIME, MML +;; Keywords: Gnus, MIME, S/MIME, MML ;; This file is a part of GNU Emacs. @@ -26,37 +26,170 @@ ;;; Code: (require 'smime) +(require 'mm-decode) -(defun mml-smime-verify (handle ctl) - (smime-verify-buffer) - handle) - -;;;###autoload (defun mml-smime-sign (cont) - ;; FIXME: You have to input the sender. (when (null smime-keys) - (error "Please use M-x customize RET smime RET to configure SMIME")) - (smime-sign-buffer) - (goto-char (point-min)) - (when (looking-at "^MIME-Version: 1.0") - (forward-line 1) - (delete-region (point-min) (point))) + (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))) - -;;;###autoload + (defun mml-smime-encrypt (cont) - ;; FIXME: You have to input the receiptant. - ;; FIXME: Should encrypt to myself so I can read it?? - (smime-encrypt-buffer) - (goto-char (point-min)) - (when (looking-at "^MIME-Version: 1.0") - (forward-line 1) - (delete-region (point-min) (point))) + (let (certnames certfiles tmp file tmpfiles) + ;; xxx tmp files are always an security issue + (while (setq tmp (pop cont)) + (if (and (consp tmp) (eq (car tmp) 'certfile)) + (push (cdr tmp) certnames))) + (while (setq tmp (pop certnames)) + (if (not (and (not (file-exists-p tmp)) + (get-buffer tmp))) + (push tmp certfiles) + (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) + (push file tmpfiles))) + (if (smime-encrypt-buffer certfiles) + (progn + (while (setq tmp (pop tmpfiles)) + (delete-file tmp)) + t) + (while (setq tmp (pop tmpfiles)) + (delete-file tmp)) + nil)) (goto-char (point-max))) -;;;###autoload -(defun mml-smime-setup () - ) +(defun mml-smime-sign-query () + ;; query information (what certificate) from user when MML tag is + ;; added, for use later by the signing process + (when (null smime-keys) + (customize-variable 'smime-keys) + (error "No S/MIME keys configured, use customize to add your key")) + (list 'keyfile + (if (= (length smime-keys) 1) + (cadar smime-keys) + (or (let ((from (cadr (funcall gnus-extract-address-components + (or (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "from"))) + ""))))) + (and from (smime-get-key-by-email from))) + (smime-get-key-by-email + (completing-read "Sign this part with what signature? " + smime-keys nil nil + (and (listp (car-safe smime-keys)) + (caar smime-keys)))))))) + +(defun mml-smime-get-file-cert () + (ignore-errors + (list 'certfile (read-file-name + "File with recipient's S/MIME certificate: " + smime-certificate-directory nil t "")))) + +(defun mml-smime-get-dns-cert () + ;; todo: deal with comma separated multiple recipients + (let (result who bad cert) + (condition-case () + (while (not result) + (setq who (read-from-minibuffer + (format "%sLookup certificate for: " (or bad "")) + (cadr (funcall gnus-extract-address-components + (or (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "to"))) + ""))))) + (if (setq cert (smime-cert-by-dns who)) + (setq result (list 'certfile (buffer-name cert))) + (setq bad (format "`%s' not found. " who)))) + (quit)) + result)) + +(defun mml-smime-encrypt-query () + ;; todo: add ldap support (xemacs ldap api?) + ;; todo: try dns/ldap automatically first, before prompting user + (let (certs done) + (while (not done) + (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 + (mml-smime-get-file-cert))))) + (setq done (not (y-or-n-p "Add more recipients? ")))) + certs)) + +(defun mml-smime-verify (handle ctl) + (with-temp-buffer + (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\"; " + (mm-handle-multipart-ctl-parameter ctl 'protocol))) + (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-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-security-handle 'gnus-info "Failed") + (mm-set-handle-multipart-parameter + 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)) + (smime-pkcs7-certificates-region (point-min) (point-max))) + (with-temp-buffer + (insert-buffer-substring buf) + (goto-char (point-min)) + (while (re-search-forward "-----END CERTIFICATE-----" nil t) + (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 claimed to be: " (mm-handle-multipart-from ctl) "\n" + (if addresses + (concat "Addresses in certificate: " + (mapconcat 'identity addresses ", ")) + "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" + (buffer-string) "\n"))))) + handle) + +(defun mml-smime-verify-test (handle ctl) + smime-openssl-program) (provide 'mml-smime)