X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml-smime.el;h=6ea55377e024e21ba3d181c804b264cf07632123;hp=b29048911edca87f2ce9b6ace6bef672a93cf9a4;hb=9ff43b22e07294fa5393fdea5c1e90a86edbe717;hpb=1fa0a463b5ea08c8083e56f12fae2f860a2fe537

diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el
index b29048911..6ea55377e 100644
--- a/lisp/mml-smime.el
+++ b/lisp/mml-smime.el
@@ -1,42 +1,125 @@
 ;;; mml-smime.el --- S/MIME support for MML
 
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;;   2005 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2013 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: Gnus, MIME, S/MIME, MML
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published
-;; by the Free Software Foundation; either version 2, or (at your
-;; option) any later version.
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
-;; GNU Emacs is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; General Public License for more details.
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
 ;;; Code:
 
-(eval-when-compile (require 'cl))
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 
-(defvar gnus-extract-address-components)
+(eval-when-compile (require 'cl))
 
 (require 'smime)
 (require 'mm-decode)
+(require 'mml-sec)
 (autoload 'message-narrow-to-headers "message")
 (autoload 'message-fetch-field "message")
 
+(defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl)
+  "Whether to use OpenSSL or EPG to decrypt S/MIME messages.
+Defaults to EPG if it's loaded."
+  :group 'mime-security
+  :type '(choice (const :tag "EPG" epg)
+                 (const :tag "OpenSSL" 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-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")))
+
+(defcustom mml-smime-sign-with-sender nil
+  "If t, use message sender so find a key to sign with."
+  :group 'mime-security
+  :version "24.4"
+  :type 'boolean)
+
+(defcustom mml-smime-encrypt-to-self nil
+  "If t, add your own key ID to recipient list when encryption."
+  :group 'mime-security
+  :version "24.4"
+  :type 'boolean)
+
 (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"))
@@ -46,7 +129,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))
@@ -72,7 +155,9 @@
       nil))
   (goto-char (point-max)))
 
-(defun mml-smime-sign-query ()
+(defvar gnus-extract-address-components)
+
+(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)
@@ -92,10 +177,10 @@
 					     "")))))
 		(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))))))))
+	       (gnus-completing-read "Sign this part with what signature"
+                                     (mapcar 'car smime-keys) nil nil nil
+                                     (and (listp (car-safe smime-keys))
+                                          (caar smime-keys))))))))
 
 (defun mml-smime-get-file-cert ()
   (ignore-errors
@@ -144,13 +229,16 @@
       (quit))
     result))
 
-(defun mml-smime-encrypt-query ()
+(autoload 'gnus-completing-read "gnus-util")
+
+(defun mml-smime-openssl-encrypt-query ()
   ;; todo: try dns/ldap automatically first, before prompting user
   (let (certs done)
     (while (not done)
-      (ecase (read (gnus-completing-read-with-default
-		    "ldap" "Fetch certificate from"
-		    '(("dns") ("ldap") ("file")) nil t))
+      (ecase (read (gnus-completing-read
+		    "Fetch certificate from"
+		    '("dns" "ldap" "file") t nil nil
+                    "ldap"))
 	(dns (setq certs (append certs
 				 (mml-smime-get-dns-cert))))
 	(ldap (setq certs (append certs
@@ -160,7 +248,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))
@@ -225,10 +313,291 @@
 		 (buffer-string) "\n")))))
   handle)
 
-(defun mml-smime-verify-test (handle ctl)
+(defun mml-smime-openssl-verify-test (handle ctl)
   smime-openssl-program)
 
+(defvar epg-user-id-alist)
+(defvar epg-digest-algorithm-alist)
+(defvar inhibit-redisplay)
+(defvar password-cache-expiry)
+
+(eval-when-compile
+  (autoload 'epg-make-context "epg")
+  (autoload 'epg-context-set-armor "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-sub-key-fingerprint "epg")
+  (autoload 'epg-configuration "epg-config")
+  (autoload 'epg-expand-group "epg-config")
+  (autoload 'epa-select-keys "epa"))
+
+(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)))))
+
+(declare-function epg-key-sub-key-list   "ext:epg" (key))
+(declare-function epg-sub-key-capability "ext:epg" (sub-key))
+(declare-function epg-sub-key-validity   "ext:epg" (sub-key))
+
+(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)))))
+
+;; XXX: since gpg --list-secret-keys does not return validity of each
+;; key, `mml-smime-epg-find-usable-key' defined above is not enough for
+;; secret keys.  The function `mml-smime-epg-find-usable-secret-key'
+;; below looks at appropriate public keys to check usability.
+(defun mml-smime-epg-find-usable-secret-key (context name usage)
+  (let ((secret-keys (epg-list-keys context name t))
+	secret-key)
+    (while (and (not secret-key) secret-keys)
+      (if (mml-smime-epg-find-usable-key
+	   (epg-list-keys context (epg-sub-key-fingerprint
+				   (car (epg-key-sub-key-list
+					 (car secret-keys)))))
+	   usage)
+	  (setq secret-key (car secret-keys)
+		secret-keys nil)
+	(setq secret-keys (cdr secret-keys))))
+    secret-key))
+
+(autoload 'mml-compute-boundary "mml")
+
+;; We require mm-decode, which requires mm-bodies, which autoloads
+;; message-options-get (!).
+(declare-function message-options-set "message" (symbol value))
+
+(defun mml-smime-epg-sign (cont)
+  (let* ((inhibit-redisplay t)
+	 (context (epg-make-context 'CMS))
+	 (boundary (mml-compute-boundary cont))
+	 (sender (message-options-get 'message-sender))
+	 (signer-names (or mml-smime-signers
+			   (if (and mml-smime-sign-with-sender sender)
+			       (list (concat "<" sender ">")))))
+	 signer-key
+	 (signers
+	  (or (message-options-get 'mml-smime-epg-signers)
+	      (message-options-set
+	       'mml-smime-epg-signers
+	       (if (eq mm-sign-option 'guided)
+		   (epa-select-keys context "\
+Select keys for signing.
+If no one is selected, default secret key is used.  "
+				    signer-names
+				    t)
+		 (if (or sender mml-smime-signers)
+		     (delq nil
+			   (mapcar
+			    (lambda (signer)
+			      (setq signer-key
+				    (mml-smime-epg-find-usable-secret-key
+				     context signer '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)
+			    signer-names)))))))
+	 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
+					 (mm-replace-in-string (buffer-string)
+							       "\n" "\r\n")
+					 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
+	 (sender (message-options-get 'message-sender))
+	 (signer-names (or mml-smime-signers
+			   (if (and mml-smime-sign-with-sender sender)
+			       (list (concat "<" sender ">")))))
+	 (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,]+"))))
+      (when mml-smime-encrypt-to-self
+	(unless signer-names
+	  (error "Neither message sender nor mml-smime-signers are set"))
+	(setq recipients (nconc recipients signer-names)))
+      (if (eq mm-encrypt-option 'guided)
+	  (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 (or (mm-find-part-by-type
+					   (cdr handle)
+					   "application/pkcs7-signature"
+					   nil t)
+					  (mm-find-part-by-type
+					   (cdr handle)
+					   "application/x-pkcs7-signature"
+					   nil t)))))
+	(mm-set-handle-multipart-parameter
+	 mm-security-handle 'gnus-info "Corrupted")
+	(throw 'error handle))
+      (setq part (mm-replace-in-string part "\n" "\r\n")
+	    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
 ;;; mml-smime.el ends here