X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0dfe7002a6b6f330b981e2d40f372bf71eeac1df..a0844f15cad956a31f8a2cdb22df9ac9962ea95a:/lisp/gnus/mml-smime.el

diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el
index 58d3b4680b..02e602ce77 100644
--- a/lisp/gnus/mml-smime.el
+++ b/lisp/gnus/mml-smime.el
@@ -1,6 +1,6 @@
 ;;; mml-smime.el --- S/MIME support for MML
 
-;; Copyright (C) 2000-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: Gnus, MIME, S/MIME, MML
@@ -32,9 +32,17 @@
 (autoload 'message-narrow-to-headers "message")
 (autoload 'message-fetch-field "message")
 
+;; Prefer epg over openssl if it is available as epg uses GnuPG's gpgsm,
+;; which features full-fledged certificate management, while openssl requires
+;; major manual efforts for certificate revocation and expiry and has bugs
+;; as documented under man smime(1).
+(ignore-errors (require 'epg))
+
 (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."
+  "Whether to use OpenSSL or EasyPG (EPG) to handle S/MIME messages.
+Defaults to EPG if it's available.
+If you think about using OpenSSL, please read the BUGS section in the manual
+for the `smime' command coming with OpenSSL first.  EasyPG is recommended."
   :group 'mime-security
   :type '(choice (const :tag "EPG" epg)
                  (const :tag "OpenSSL" openssl)))
@@ -57,6 +65,9 @@ Defaults to EPG if it's loaded."
   "If t, cache passphrase."
   :group 'mime-security
   :type 'boolean)
+(make-obsolete-variable 'mml-smime-cache-passphrase
+			'mml-secure-cache-passphrase
+			"25.1")
 
 (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
   "How many seconds the passphrase is cached.
@@ -64,6 +75,9 @@ Whether the passphrase is cached at all is controlled by
 `mml-smime-cache-passphrase'."
   :group 'mime-security
   :type 'integer)
+(make-obsolete-variable 'mml-smime-passphrase-cache-expiry
+			'mml-secure-passphrase-cache-expiry
+			"25.1")
 
 (defcustom mml-smime-signers nil
   "A list of your own key ID which will be used to sign a message."
@@ -135,8 +149,7 @@ Whether the passphrase is cached at all is controlled by
       (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)))
+	(setq file (make-temp-file (expand-file-name "mml." mm-tmp-directory)))
 	(with-current-buffer tmp
 	  (write-region (point-min) (point-max) file))
 	(push file certfiles)
@@ -162,15 +175,12 @@ Whether the passphrase is cached at all is controlled by
   (list 'keyfile
 	(if (= (length smime-keys) 1)
 	    (cadar smime-keys)
-	  (or (let ((from (cadr (funcall (if (boundp
-					      'gnus-extract-address-components)
-					     gnus-extract-address-components
-					   'mail-extract-address-components)
-					 (or (save-excursion
-					       (save-restriction
-						 (message-narrow-to-headers)
-						 (message-fetch-field "from")))
-					     "")))))
+	  (or (let ((from (cadr (mail-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
 	       (gnus-completing-read "Sign this part with what signature"
@@ -191,18 +201,15 @@ Whether the passphrase is cached at all is controlled by
 	(while (not result)
 	  (setq who (read-from-minibuffer
 		     (format "%sLookup certificate for: " (or bad ""))
-		     (cadr (funcall (if (boundp
-					 'gnus-extract-address-components)
-					gnus-extract-address-components
-				      'mail-extract-address-components)
-				    (or (save-excursion
-					  (save-restriction
-					    (message-narrow-to-headers)
-					    (message-fetch-field "to")))
-					"")))))
+		     (cadr (mail-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))))
+	    (setq bad (format-message "`%s' not found. " who))))
       (quit))
     result))
 
@@ -221,7 +228,7 @@ Whether the passphrase is cached at all is controlled by
 					"")))))
 	  (if (setq cert (smime-cert-by-ldap who))
 	      (setq result (list 'certfile (buffer-name cert)))
-	    (setq bad (format "`%s' not found. " who))))
+	    (setq bad (format-message "`%s' not found. " who))))
       (quit))
     result))
 
@@ -336,62 +343,9 @@ Whether the passphrase is cached at all is controlled by
   (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))
+(declare-function epg-key-sub-key-list   "epg" (key) t)
+(declare-function epg-sub-key-capability "epg" (sub-key) t)
+(declare-function epg-sub-key-validity   "epg" (sub-key) t)
 
 (autoload 'mml-compute-boundary "mml")
 
@@ -400,146 +354,37 @@ Whether the passphrase is cached at all is controlled by
 (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)))))
+  (let ((inhibit-redisplay t)
+	(boundary (mml-compute-boundary cont)))
     (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
+    (let* ((pair (mml-secure-epg-sign 'CMS cont))
+	   (signature (car pair))
+	   (micalg (cdr pair)))
+      (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))))
+      (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))))
+	 (cipher (mml-secure-epg-encrypt 'CMS cont)))
     (delete-region (point-min) (point-max))
     (goto-char (point-min))
     (insert "\
@@ -573,7 +418,7 @@ Content-Disposition: attachment; filename=smime.p7m
 	(mm-set-handle-multipart-parameter
 	 mm-security-handle 'gnus-info "Corrupted")
 	(throw 'error handle))
-      (setq part (mm-replace-in-string part "\n" "\r\n")
+      (setq part (replace-regexp-in-string "\n" "\r\n" part)
 	    context (epg-make-context 'CMS))
       (condition-case error
 	  (setq plain (epg-verify-string context (mm-get-part signature) part))