From bdcc91d5d7080f9d505a2e253e3e163e47ed04b8 Mon Sep 17 00:00:00 2001 From: Daiki Ueno Date: Tue, 6 Mar 2007 05:16:37 +0000 Subject: [PATCH] * mml-smime.el (mml-smime-use): New variable; default to use openssl. (mml-smime-function-alist): New variable; add epg as the backend. * mml-sec.el (mml-smime-sign): Don't require mml-smime, autoload mml-smime- functions instead. * mm-view.el: Require smime. --- lisp/ChangeLog | 8 ++ lisp/mm-view.el | 1 + lisp/mml-sec.el | 7 +- lisp/mml-smime.el | 319 +++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 329 insertions(+), 6 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b629ab437..24ae1909e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2007-03-06 Daiki Ueno + + * mml-smime.el (mml-smime-use): New variable; default to use openssl. + (mml-smime-function-alist): New variable; add epg as the backend. + * mml-sec.el (mml-smime-sign): Don't require mml-smime, autoload + mml-smime- functions instead. + * mm-view.el: Require smime. + 2007-03-05 Didier Verna * gnus-topic.el (gnus-topic-hierarchical-parameters): Perform merging diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 6f110c55e..714390e48 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -30,6 +30,7 @@ (require 'mailcap) (require 'mm-bodies) (require 'mm-decode) +(require 'smime) (eval-and-compile (autoload 'gnus-article-prepare-display "gnus-art") diff --git a/lisp/mml-sec.el b/lisp/mml-sec.el index 7e9d6e345..d4433c9ad 100644 --- a/lisp/mml-sec.el +++ b/lisp/mml-sec.el @@ -26,7 +26,6 @@ ;;; Code: -(require 'mml-smime) (eval-when-compile (require 'cl)) (require 'password) (autoload 'mml2015-sign "mml2015") @@ -35,6 +34,12 @@ (autoload 'mml1991-encrypt "mml1991") (autoload 'message-goto-body "message") (autoload 'mml-insert-tag "mml") +(autoload 'mml-smime-sign "mml-smime") +(autoload 'mml-smime-encrypt "mml-smime") +(autoload 'mml-smime-sign-query "mml-smime") +(autoload 'mml-smime-encrypt-query "mml-smime") +(autoload 'mml-smime-verify "mml-smime") +(autoload 'mml-smime-verify-test "mml-smime") (defvar mml-sign-alist '(("smime" mml-smime-sign-buffer mml-smime-sign-query) diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el index a4470ad62..d14ccb728 100644 --- a/lisp/mml-smime.el +++ b/lisp/mml-smime.el @@ -31,10 +31,82 @@ (require 'smime) (require 'mm-decode) +(require 'mml-sec) (autoload 'message-narrow-to-headers "message") (autoload 'message-fetch-field "message") +(defvar mml-smime-use 'openssl) + +(defvar mml-smime-function-alist + '((openssl mml-smime-openssl-sign + mml-smime-openssl-encrypt + mml-smime-openssl-sign-query + mml-smime-openssl-encrypt-query + mml-smime-openssl-verify + mml-smime-openssl-verify-test) + (epg mml-smime-epg-sign + mml-smime-epg-encrypt + nil + nil + mml-smime-epg-verify + mml-smime-epg-verify-test))) + +(defcustom mml-smime-verbose mml-secure-verbose + "If non-nil, ask the user about the current operation more verbosely." + :group 'mime-security + :type 'boolean) + +(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase + "If t, cache passphrase." + :group 'mime-security + :type 'boolean) + +(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml-smime-cache-passphrase'." + :group 'mime-security + :type 'integer) + +(defcustom mml-smime-signers nil + "A list of your own key ID which will be used to sign a message." + :group 'mime-security + :type '(repeat (string :tag "Key ID"))) + (defun mml-smime-sign (cont) + (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func cont) + (error "Cannot find sign function")))) + +(defun mml-smime-encrypt (cont) + (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func cont) + (error "Cannot find encrypt function")))) + +(defun mml-smime-sign-query () + (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func)))) + +(defun mml-smime-encrypt-query () + (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func)))) + +(defun mml-smime-verify (handle ctl) + (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func handle ctl) + handle))) + +(defun mml-smime-verify-test (handle ctl) + (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func handle ctl)))) + +(defun mml-smime-openssl-sign (cont) (when (null smime-keys) (customize-variable 'smime-keys) (error "No S/MIME keys configured, use customize to add your key")) @@ -44,7 +116,7 @@ (replace-match "\n" t t)) (goto-char (point-max))) -(defun mml-smime-encrypt (cont) +(defun mml-smime-openssl-encrypt (cont) (let (certnames certfiles tmp file tmpfiles) ;; xxx tmp files are always an security issue (while (setq tmp (pop cont)) @@ -70,7 +142,7 @@ nil)) (goto-char (point-max))) -(defun mml-smime-sign-query () +(defun mml-smime-openssl-sign-query () ;; query information (what certificate) from user when MML tag is ;; added, for use later by the signing process (when (null smime-keys) @@ -142,7 +214,7 @@ (quit)) result)) -(defun mml-smime-encrypt-query () +(defun mml-smime-openssl-encrypt-query () ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) @@ -158,7 +230,7 @@ (setq done (not (y-or-n-p "Add more recipients? ")))) certs)) -(defun mml-smime-verify (handle ctl) +(defun mml-smime-openssl-verify (handle ctl) (with-temp-buffer (insert-buffer-substring (mm-handle-multipart-original-buffer ctl)) (goto-char (point-min)) @@ -223,9 +295,246 @@ (buffer-string) "\n"))))) handle) -(defun mml-smime-verify-test (handle ctl) +(defun mml-smime-openssl-verify-test (handle ctl) smime-openssl-program) +(eval-and-compile + (autoload 'epg-make-context "epg")) + +(eval-when-compile + (defvar epg-user-id-alist) + (defvar epg-digest-algorithm-alist) + (defvar inhibit-redisplay) + (autoload 'epg-context-set-armor "epg") + (autoload 'epg-context-set-textmode "epg") + (autoload 'epg-context-set-signers "epg") + (autoload 'epg-context-result-for "epg") + (autoload 'epg-new-signature-digest-algorithm "epg") + (autoload 'epg-verify-result-to-string "epg") + (autoload 'epg-list-keys "epg") + (autoload 'epg-decrypt-string "epg") + (autoload 'epg-verify-string "epg") + (autoload 'epg-sign-string "epg") + (autoload 'epg-encrypt-string "epg") + (autoload 'epg-passphrase-callback-function "epg") + (autoload 'epg-context-set-passphrase-callback "epg") + (autoload 'epg-configuration "epg-config") + (autoload 'epg-expand-group "epg-config") + (autoload 'epa-select-keys "epa")) + +(eval-when-compile + (defvar password-cache-expiry) + (autoload 'password-read "password") + (autoload 'password-cache-add "password") + (autoload 'password-cache-remove "password")) + +(defvar mml-smime-epg-secret-key-id-list nil) + +(defun mml-smime-epg-passphrase-callback (context key-id ignore) + (if (eq key-id 'SYM) + (epg-passphrase-callback-function context key-id nil) + (let* (entry + (passphrase + (password-read + (if (eq key-id 'PIN) + "Passphrase for PIN: " + (if (setq entry (assoc key-id epg-user-id-alist)) + (format "Passphrase for %s %s: " key-id (cdr entry)) + (format "Passphrase for %s: " key-id))) + (if (eq key-id 'PIN) + "PIN" + key-id)))) + (when passphrase + (let ((password-cache-expiry mml-smime-passphrase-cache-expiry)) + (password-cache-add key-id passphrase)) + (setq mml-smime-epg-secret-key-id-list + (cons key-id mml-smime-epg-secret-key-id-list)) + (copy-sequence passphrase))))) + +(defun mml-smime-epg-find-usable-key (keys usage) + (catch 'found + (while keys + (let ((pointer (epg-key-sub-key-list (car keys)))) + (while pointer + (if (and (memq usage (epg-sub-key-capability (car pointer))) + (not (memq (epg-sub-key-validity (car pointer)) + '(revoked expired)))) + (throw 'found (car keys))) + (setq pointer (cdr pointer)))) + (setq keys (cdr keys))))) + +(defun mml-smime-epg-sign (cont) + (let* ((inhibit-redisplay t) + (context (epg-make-context 'CMS)) + (boundary (mml-compute-boundary cont)) + signer-key + (signers + (or (message-options-get 'mml-smime-epg-signers) + (message-options-set + 'mml-smime-epg-signers + (if mml-smime-verbose + (epa-select-keys context "\ +Select keys for signing. +If no one is selected, default secret key is used. " + mml-smime-signers t) + (if mml-smime-signers + (mapcar + (lambda (signer) + (setq signer-key (mml-smime-epg-find-usable-key + (epg-list-keys context signer t) + 'sign)) + (unless (or signer-key + (y-or-n-p + (format "No secret key for %s; skip it? " + signer))) + (error "No secret key for %s" signer)) + signer-key) + mml-smime-signers)))))) + signature micalg) + (epg-context-set-signers context signers) + (if mml-smime-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml-smime-epg-passphrase-callback)) + (condition-case error + (setq signature (epg-sign-string context (buffer-string) t) + mml-smime-epg-secret-key-id-list nil) + (error + (while mml-smime-epg-secret-key-id-list + (password-cache-remove (car mml-smime-epg-secret-key-id-list)) + (setq mml-smime-epg-secret-key-id-list + (cdr mml-smime-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (if (epg-context-result-for context 'sign) + (setq micalg (epg-new-signature-digest-algorithm + (car (epg-context-result-for context 'sign))))) + (goto-char (point-min)) + (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" + boundary)) + (if micalg + (insert (format "\tmicalg=%s; " + (downcase + (cdr (assq micalg + epg-digest-algorithm-alist)))))) + (insert "protocol=\"application/pkcs7-signature\"\n") + (insert (format "\n--%s\n" boundary)) + (goto-char (point-max)) + (insert (format "\n--%s\n" boundary)) + (insert "Content-Type: application/pkcs7-signature; name=smime.p7s +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=smime.p7s + +") + (insert (base64-encode-string signature) "\n") + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max)))) + +(defun mml-smime-epg-encrypt (cont) + (let ((inhibit-redisplay t) + (context (epg-make-context 'CMS)) + (config (epg-configuration)) + (recipients (message-options-get 'mml-smime-epg-recipients)) + cipher signers + (boundary (mml-compute-boundary cont)) + recipient-key) + (unless recipients + (setq recipients + (apply #'nconc + (mapcar + (lambda (recipient) + (or (epg-expand-group config recipient) + (list recipient))) + (split-string + (or (message-options-get 'message-recipients) + (message-options-set 'message-recipients + (read-string "Recipients: "))) + "[ \f\t\n\r\v,]+")))) + (if mml-smime-verbose + (setq recipients + (epa-select-keys context "\ +Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients)) + (setq recipients + (mapcar + (lambda (recipient) + (setq recipient-key (mml-smime-epg-find-usable-key + (epg-list-keys context recipient) + 'encrypt)) + (unless (or recipient-key + (y-or-n-p + (format "No public key for %s; skip it? " + recipient))) + (error "No public key for %s" recipient)) + recipient-key) + recipients)) + (unless recipients + (error "No recipient specified"))) + (message-options-set 'mml-smime-epg-recipients recipients)) + (if mml-smime-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml-smime-epg-passphrase-callback)) + (condition-case error + (setq cipher + (epg-encrypt-string context (buffer-string) recipients) + mml-smime-epg-secret-key-id-list nil) + (error + (while mml-smime-epg-secret-key-id-list + (password-cache-remove (car mml-smime-epg-secret-key-id-list)) + (setq mml-smime-epg-secret-key-id-list + (cdr mml-smime-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert "\ +Content-Type: application/pkcs7-mime; + smime-type=enveloped-data; + name=smime.p7m +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=smime.p7m + +") + (insert (base64-encode-string cipher)) + (goto-char (point-max)))) + +(defun mml-smime-epg-verify (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain signature-file part signature) + (when (or (null (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter + ctl 'protocol) + "application/pkcs7-signature") + t))) + (null (setq signature (mm-find-part-by-type + (cdr handle) + "application/pkcs7-signature" + nil t)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (setq context (epg-make-context 'CMS)) + (condition-case error + (setq plain (epg-verify-string context (mm-get-part signature) part)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (format "%S" error))) + (throw 'error handle))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (epg-verify-result-to-string (epg-context-result-for context 'verify))) + handle))) + +(defun mml-smime-epg-verify-test (handle ctl) + t) + (provide 'mml-smime) ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 -- 2.25.1