X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml-smime.el;h=16eff67834b58ea302d406905e0568384158f8f6;hb=82d219ce980dc263c9288225f901635336101fb4;hp=6a745df8bca1aad5b435c30c740ae03073e1a25e;hpb=b844f1d691e07af8a3b654d9a01a6c463cbef7c9;p=gnus diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el index 6a745df8b..16eff6783 100644 --- a/lisp/mml-smime.el +++ b/lisp/mml-smime.el @@ -2,7 +2,7 @@ ;; Copyright (c) 2000 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. @@ -23,46 +23,144 @@ ;;; Commentary: -;; This support creation of S/MIME parts in MML. - -;; Usage: -;; (mml-smime-setup) -;; -;; Insert an attribute, postprocess=smime-sign (or smime-encrypt), into -;; the mml tag to be signed (or encrypted). -;; -;; It is based on rfc2015.el by Shenghuo Zhu. - ;;; Code: (require 'smime) +(require 'mm-decode) -;;;###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))) - (goto-char (point-max))) - -;;;###autoload + (smime-sign-buffer (cdr (assq 'keyfile cont)))) + (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))) - (goto-char (point-max))) - -;;;###autoload -(defun mml-smime-setup () - (setq mml-generate-mime-postprocess-function 'mml-postprocess)) + (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 (make-temp-name 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))) + +(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 "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-current-buffer (mm-handle-multipart-original-buffer ctl) + ;; xxx modifies buffer -- noone else uses the buffer, so what the heck + (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)) + (if (smime-verify-buffer) + ;; 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 (mm-handle-multipart-original-buffer ctl)) + (if (not (member mm-security-from + (and (smime-pkcs7-email-region + (point-min) (point-max)) + (smime-buffer-as-string-region + (point-min) (point-max))))) + (progn + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Sender forged") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (with-current-buffer + (mm-handle-multipart-original-buffer ctl) + (buffer-string)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (kill-buffer smime-details-buffer)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (with-current-buffer smime-details-buffer + (buffer-string)))) + handle)) + +(defun mml-smime-verify-test (handle ctl) + smime-openssl-program) (provide 'mml-smime)