[bpt/emacs.git] / lisp / gnus / mml-smime.el

;;; mml-smime.el --- S/MIME support for MML

;; 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 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; For Emacs <22.2 and XEmacs.
(eval-and-compile
  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))

(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")))

(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"))
  (smime-sign-buffer (cdr (assq 'keyfile cont)))
  (goto-char (point-min))
  (while (search-forward "\r\n" nil t)
    (replace-match "\n" t t))
  (goto-char (point-max)))

(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))
      (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)))

(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)
    (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 (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")))
					     "")))))
		(and from (smime-get-key-by-email from)))
	      (smime-get-key-by-email
	       (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
    (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 (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")))
					"")))))
	  (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-get-ldap-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-ldap who))
	      (setq result (list 'certfile (buffer-name cert)))
	    (setq bad (format "`%s' not found. " who))))
      (quit))
    result))

(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
		    "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
				  (mml-smime-get-ldap-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-openssl-verify (handle ctl)
  (with-temp-buffer
    (insert-buffer-substring (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-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-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)))))

(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))
	 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.  "
				   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
					 (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
	(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 (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)

;;; mml-smime.el ends here
Commit	Line	Data
23f87bed	1	;;; mml-smime.el --- S/MIME support for MML
e84b4b86	2
ab422c4d	3	;; Copyright (C) 2000-2013 Free Software Foundation, Inc.
23f87bed MB	4
	5	;; Author: Simon Josefsson <simon@josefsson.org>
	6	;; Keywords: Gnus, MIME, S/MIME, MML
	7
	8	;; This file is part of GNU Emacs.
	9
5e809f55 GM	10	;; GNU Emacs is free software: you can redistribute it and/or modify
	11	;; it under the terms of the GNU General Public License as published by
	12	;; the Free Software Foundation, either version 3 of the License, or
	13	;; (at your option) any later version.
23f87bed	14
5e809f55 GM	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
23f87bed MB	19
23f87bed MB	20	;; You should have received a copy of the GNU General Public License
5e809f55	21	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23f87bed MB	22
	23	;;; Commentary:
	24
	25	;;; Code:
	26
f0b7f5a8	27	;; For Emacs <22.2 and XEmacs.
431e6df6 GM	28	(eval-and-compile
	29	(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
	30
c1d7d285 MB	31	(eval-when-compile (require 'cl))
c1d7d285 MB	32
23f87bed MB	33	(require 'smime)
23f87bed MB	34	(require 'mm-decode)
01c52d31	35	(require 'mml-sec)
23f87bed	36	(autoload 'message-narrow-to-headers "message")
c1d7d285	37	(autoload 'message-fetch-field "message")
23f87bed	38
c5ecc769 G	39	(defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl)
	40	"Whether to use OpenSSL or EPG to decrypt S/MIME messages.
	41	Defaults to EPG if it's loaded."
	42	:group 'mime-security
	43	:type '(choice (const :tag "EPG" epg)
	44	(const :tag "OpenSSL" openssl)))
01c52d31 MB	45
	46	(defvar mml-smime-function-alist
	47	'((openssl mml-smime-openssl-sign
	48	mml-smime-openssl-encrypt
	49	mml-smime-openssl-sign-query
	50	mml-smime-openssl-encrypt-query
	51	mml-smime-openssl-verify
	52	mml-smime-openssl-verify-test)
	53	(epg mml-smime-epg-sign
	54	mml-smime-epg-encrypt
	55	nil
	56	nil
	57	mml-smime-epg-verify
	58	mml-smime-epg-verify-test)))
	59
01c52d31 MB	60	(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
	61	"If t, cache passphrase."
	62	:group 'mime-security
	63	:type 'boolean)
	64
	65	(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
	66	"How many seconds the passphrase is cached.
	67	Whether the passphrase is cached at all is controlled by
	68	`mml-smime-cache-passphrase'."
	69	:group 'mime-security
	70	:type 'integer)
	71
	72	(defcustom mml-smime-signers nil
	73	"A list of your own key ID which will be used to sign a message."
	74	:group 'mime-security
	75	:type '(repeat (string :tag "Key ID")))
	76
23f87bed	77	(defun mml-smime-sign (cont)
01c52d31 MB	78	(let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
	79	(if func
	80	(funcall func cont)
	81	(error "Cannot find sign function"))))
	82
	83	(defun mml-smime-encrypt (cont)
	84	(let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
	85	(if func
	86	(funcall func cont)
	87	(error "Cannot find encrypt function"))))
	88
	89	(defun mml-smime-sign-query ()
	90	(let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
	91	(if func
	92	(funcall func))))
	93
	94	(defun mml-smime-encrypt-query ()
	95	(let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
	96	(if func
	97	(funcall func))))
	98
	99	(defun mml-smime-verify (handle ctl)
	100	(let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
	101	(if func
	102	(funcall func handle ctl)
	103	handle)))
	104
	105	(defun mml-smime-verify-test (handle ctl)
	106	(let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
	107	(if func
	108	(funcall func handle ctl))))
	109
	110	(defun mml-smime-openssl-sign (cont)
23f87bed MB	111	(when (null smime-keys)
	112	(customize-variable 'smime-keys)
	113	(error "No S/MIME keys configured, use customize to add your key"))
	114	(smime-sign-buffer (cdr (assq 'keyfile cont)))
	115	(goto-char (point-min))
	116	(while (search-forward "\r\n" nil t)
	117	(replace-match "\n" t t))
	118	(goto-char (point-max)))
	119
01c52d31	120	(defun mml-smime-openssl-encrypt (cont)
23f87bed MB	121	(let (certnames certfiles tmp file tmpfiles)
	122	;; xxx tmp files are always an security issue
	123	(while (setq tmp (pop cont))
	124	(if (and (consp tmp) (eq (car tmp) 'certfile))
	125	(push (cdr tmp) certnames)))
	126	(while (setq tmp (pop certnames))
	127	(if (not (and (not (file-exists-p tmp))
	128	(get-buffer tmp)))
	129	(push tmp certfiles)
8d1d11d8	130	(setq file (mm-make-temp-file (expand-file-name "mml."
23f87bed MB	131	mm-tmp-directory)))
	132	(with-current-buffer tmp
	133	(write-region (point-min) (point-max) file))
	134	(push file certfiles)
	135	(push file tmpfiles)))
	136	(if (smime-encrypt-buffer certfiles)
	137	(progn
	138	(while (setq tmp (pop tmpfiles))
	139	(delete-file tmp))
	140	t)
	141	(while (setq tmp (pop tmpfiles))
	142	(delete-file tmp))
	143	nil))
	144	(goto-char (point-max)))
	145
ec374c91 GM	146	(defvar gnus-extract-address-components)
ec374c91 GM	147
01c52d31	148	(defun mml-smime-openssl-sign-query ()
23f87bed MB	149	;; query information (what certificate) from user when MML tag is
	150	;; added, for use later by the signing process
	151	(when (null smime-keys)
	152	(customize-variable 'smime-keys)
	153	(error "No S/MIME keys configured, use customize to add your key"))
	154	(list 'keyfile
	155	(if (= (length smime-keys) 1)
	156	(cadar smime-keys)
4a2358e9 MB	157	(or (let ((from (cadr (funcall (if (boundp
	158	'gnus-extract-address-components)
	159	gnus-extract-address-components
	160	'mail-extract-address-components)
23f87bed MB	161	(or (save-excursion
	162	(save-restriction
	163	(message-narrow-to-headers)
	164	(message-fetch-field "from")))
	165	"")))))
	166	(and from (smime-get-key-by-email from)))
	167	(smime-get-key-by-email
229b59da	168	(gnus-completing-read "Sign this part with what signature"
71e691a5	169	(mapcar 'car smime-keys) nil nil nil
229b59da G	170	(and (listp (car-safe smime-keys))
229b59da G	171	(caar smime-keys))))))))
23f87bed MB	172
	173	(defun mml-smime-get-file-cert ()
	174	(ignore-errors
	175	(list 'certfile (read-file-name
	176	"File with recipient's S/MIME certificate: "
	177	smime-certificate-directory nil t ""))))
	178
	179	(defun mml-smime-get-dns-cert ()
	180	;; todo: deal with comma separated multiple recipients
	181	(let (result who bad cert)
	182	(condition-case ()
	183	(while (not result)
	184	(setq who (read-from-minibuffer
	185	(format "%sLookup certificate for: " (or bad ""))
4a2358e9 MB	186	(cadr (funcall (if (boundp
	187	'gnus-extract-address-components)
	188	gnus-extract-address-components
	189	'mail-extract-address-components)
23f87bed MB	190	(or (save-excursion
	191	(save-restriction
	192	(message-narrow-to-headers)
	193	(message-fetch-field "to")))
	194	"")))))
	195	(if (setq cert (smime-cert-by-dns who))
	196	(setq result (list 'certfile (buffer-name cert)))
	197	(setq bad (format "`%s' not found. " who))))
	198	(quit))
	199	result))
	200
01c52d31 MB	201	(defun mml-smime-get-ldap-cert ()
	202	;; todo: deal with comma separated multiple recipients
	203	(let (result who bad cert)
	204	(condition-case ()
	205	(while (not result)
	206	(setq who (read-from-minibuffer
	207	(format "%sLookup certificate for: " (or bad ""))
	208	(cadr (funcall gnus-extract-address-components
	209	(or (save-excursion
	210	(save-restriction
	211	(message-narrow-to-headers)
	212	(message-fetch-field "to")))
	213	"")))))
	214	(if (setq cert (smime-cert-by-ldap who))
	215	(setq result (list 'certfile (buffer-name cert)))
	216	(setq bad (format "`%s' not found. " who))))
	217	(quit))
	218	result))
	219
229b59da	220	(autoload 'gnus-completing-read "gnus-util")
431e6df6	221
01c52d31	222	(defun mml-smime-openssl-encrypt-query ()
23f87bed MB	223	;; todo: try dns/ldap automatically first, before prompting user
	224	(let (certs done)
	225	(while (not done)
229b59da G	226	(ecase (read (gnus-completing-read
229b59da G	227	"Fetch certificate from"
71e691a5	228	'("dns" "ldap" "file") t nil nil
229b59da	229	"ldap"))
23f87bed MB	230	(dns (setq certs (append certs
23f87bed MB	231	(mml-smime-get-dns-cert))))
01c52d31 MB	232	(ldap (setq certs (append certs
01c52d31 MB	233	(mml-smime-get-ldap-cert))))
23f87bed MB	234	(file (setq certs (append certs
	235	(mml-smime-get-file-cert)))))
	236	(setq done (not (y-or-n-p "Add more recipients? "))))
	237	certs))
	238
01c52d31	239	(defun mml-smime-openssl-verify (handle ctl)
23f87bed MB	240	(with-temp-buffer
	241	(insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
	242	(goto-char (point-min))
	243	(insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
	244	(insert (format "protocol=\"%s\"; "
	245	(mm-handle-multipart-ctl-parameter ctl 'protocol)))
	246	(insert (format "micalg=\"%s\"; "
	247	(mm-handle-multipart-ctl-parameter ctl 'micalg)))
	248	(insert (format "boundary=\"%s\"\n\n"
	249	(mm-handle-multipart-ctl-parameter ctl 'boundary)))
	250	(when (get-buffer smime-details-buffer)
	251	(kill-buffer smime-details-buffer))
	252	(let ((buf (current-buffer))
	253	(good-signature (smime-noverify-buffer))
	254	(good-certificate (and (or smime-CA-file smime-CA-directory)
	255	(smime-verify-buffer)))
	256	addresses openssl-output)
	257	(setq openssl-output (with-current-buffer smime-details-buffer
	258	(buffer-string)))
	259	(if (not good-signature)
	260	(progn
	261	;; we couldn't verify message, fail with openssl output as message
	262	(mm-set-handle-multipart-parameter
	263	mm-security-handle 'gnus-info "Failed")
	264	(mm-set-handle-multipart-parameter
	265	mm-security-handle 'gnus-details
	266	(concat "OpenSSL failed to verify message integrity:\n"
	267	"-------------------------------------------\n"
	268	openssl-output)))
	269	;; verify mail addresses in mail against those in certificate
	270	(when (and (smime-pkcs7-region (point-min) (point-max))
	271	(smime-pkcs7-certificates-region (point-min) (point-max)))
	272	(with-temp-buffer
	273	(insert-buffer-substring buf)
	274	(goto-char (point-min))
	275	(while (re-search-forward "-----END CERTIFICATE-----" nil t)
	276	(when (smime-pkcs7-email-region (point-min) (point))
	277	(setq addresses (append (smime-buffer-as-string-region
	278	(point-min) (point)) addresses)))
	279	(delete-region (point-min) (point)))
	280	(setq addresses (mapcar 'downcase addresses))))
	281	(if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
	282	(mm-set-handle-multipart-parameter
	283	mm-security-handle 'gnus-info "Sender address forged")
	284	(if good-certificate
	285	(mm-set-handle-multipart-parameter
	286	mm-security-handle 'gnus-info "Ok (sender authenticated)")
	287	(mm-set-handle-multipart-parameter
	288	mm-security-handle 'gnus-info "Ok (sender not trusted)")))
	289	(mm-set-handle-multipart-parameter
	290	mm-security-handle 'gnus-details
	291	(concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
	292	(if addresses
	293	(concat "Addresses in certificate: "
	294	(mapconcat 'identity addresses ", "))
	295	"No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
	296	"\n" "\n"
	297	"OpenSSL output:\n"
	298	"---------------\n" openssl-output "\n"
	299	"Certificate(s) inside S/MIME signature:\n"
	300	"---------------------------------------\n"
	301	(buffer-string) "\n")))))
	302	handle)
	303
01c52d31	304	(defun mml-smime-openssl-verify-test (handle ctl)
23f87bed MB	305	smime-openssl-program)
23f87bed MB	306
9efa445f DN	307	(defvar epg-user-id-alist)
	308	(defvar epg-digest-algorithm-alist)
	309	(defvar inhibit-redisplay)
	310	(defvar password-cache-expiry)
01c52d31 MB	311
01c52d31 MB	312	(eval-when-compile
9efa445f	313	(autoload 'epg-make-context "epg")
01c52d31 MB	314	(autoload 'epg-context-set-armor "epg")
	315	(autoload 'epg-context-set-signers "epg")
	316	(autoload 'epg-context-result-for "epg")
	317	(autoload 'epg-new-signature-digest-algorithm "epg")
	318	(autoload 'epg-verify-result-to-string "epg")
	319	(autoload 'epg-list-keys "epg")
	320	(autoload 'epg-decrypt-string "epg")
	321	(autoload 'epg-verify-string "epg")
	322	(autoload 'epg-sign-string "epg")
	323	(autoload 'epg-encrypt-string "epg")
	324	(autoload 'epg-passphrase-callback-function "epg")
	325	(autoload 'epg-context-set-passphrase-callback "epg")
	326	(autoload 'epg-configuration "epg-config")
	327	(autoload 'epg-expand-group "epg-config")
ec374c91	328	(autoload 'epa-select-keys "epa"))
01c52d31 MB	329
	330	(defvar mml-smime-epg-secret-key-id-list nil)
	331
	332	(defun mml-smime-epg-passphrase-callback (context key-id ignore)
	333	(if (eq key-id 'SYM)
	334	(epg-passphrase-callback-function context key-id nil)
	335	(let* (entry
	336	(passphrase
	337	(password-read
	338	(if (eq key-id 'PIN)
	339	"Passphrase for PIN: "
	340	(if (setq entry (assoc key-id epg-user-id-alist))
	341	(format "Passphrase for %s %s: " key-id (cdr entry))
	342	(format "Passphrase for %s: " key-id)))
	343	(if (eq key-id 'PIN)
	344	"PIN"
	345	key-id))))
	346	(when passphrase
	347	(let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
	348	(password-cache-add key-id passphrase))
	349	(setq mml-smime-epg-secret-key-id-list
	350	(cons key-id mml-smime-epg-secret-key-id-list))
	351	(copy-sequence passphrase)))))
	352
431e6df6 GM	353	(declare-function epg-key-sub-key-list "ext:epg" (key))
	354	(declare-function epg-sub-key-capability "ext:epg" (sub-key))
	355	(declare-function epg-sub-key-validity "ext:epg" (sub-key))
	356
01c52d31 MB	357	(defun mml-smime-epg-find-usable-key (keys usage)
	358	(catch 'found
	359	(while keys
	360	(let ((pointer (epg-key-sub-key-list (car keys))))
	361	(while pointer
	362	(if (and (memq usage (epg-sub-key-capability (car pointer)))
	363	(not (memq (epg-sub-key-validity (car pointer))
	364	'(revoked expired))))
	365	(throw 'found (car keys)))
	366	(setq pointer (cdr pointer))))
	367	(setq keys (cdr keys)))))
	368
431e6df6 GM	369	(autoload 'mml-compute-boundary "mml")
	370
	371	;; We require mm-decode, which requires mm-bodies, which autoloads
	372	;; message-options-get (!).
	373	(declare-function message-options-set "message" (symbol value))
	374
01c52d31 MB	375	(defun mml-smime-epg-sign (cont)
	376	(let* ((inhibit-redisplay t)
	377	(context (epg-make-context 'CMS))
	378	(boundary (mml-compute-boundary cont))
	379	signer-key
	380	(signers
	381	(or (message-options-get 'mml-smime-epg-signers)
	382	(message-options-set
	383	'mml-smime-epg-signers
54c72c31	384	(if (eq mm-sign-option 'guided)
01c52d31 MB	385	(epa-select-keys context "\
	386	Select keys for signing.
	387	If no one is selected, default secret key is used. "
	388	mml-smime-signers t)
	389	(if mml-smime-signers
	390	(mapcar
	391	(lambda (signer)
	392	(setq signer-key (mml-smime-epg-find-usable-key
	393	(epg-list-keys context signer t)
	394	'sign))
	395	(unless (or signer-key
	396	(y-or-n-p
	397	(format "No secret key for %s; skip it? "
	398	signer)))
	399	(error "No secret key for %s" signer))
	400	signer-key)
	401	mml-smime-signers))))))
	402	signature micalg)
	403	(epg-context-set-signers context signers)
	404	(if mml-smime-cache-passphrase
	405	(epg-context-set-passphrase-callback
	406	context
	407	#'mml-smime-epg-passphrase-callback))
	408	(condition-case error
	409	(setq signature (epg-sign-string context
	410	(mm-replace-in-string (buffer-string)
	411	"\n" "\r\n")
	412	t)
	413	mml-smime-epg-secret-key-id-list nil)
	414	(error
	415	(while mml-smime-epg-secret-key-id-list
	416	(password-cache-remove (car mml-smime-epg-secret-key-id-list))
	417	(setq mml-smime-epg-secret-key-id-list
	418	(cdr mml-smime-epg-secret-key-id-list)))
	419	(signal (car error) (cdr error))))
	420	(if (epg-context-result-for context 'sign)
	421	(setq micalg (epg-new-signature-digest-algorithm
	422	(car (epg-context-result-for context 'sign)))))
	423	(goto-char (point-min))
	424	(insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
	425	boundary))
	426	(if micalg
	427	(insert (format "\tmicalg=%s; "
	428	(downcase
	429	(cdr (assq micalg
	430	epg-digest-algorithm-alist))))))
	431	(insert "protocol=\"application/pkcs7-signature\"\n")
	432	(insert (format "\n--%s\n" boundary))
	433	(goto-char (point-max))
	434	(insert (format "\n--%s\n" boundary))
	435	(insert "Content-Type: application/pkcs7-signature; name=smime.p7s
	436	Content-Transfer-Encoding: base64
	437	Content-Disposition: attachment; filename=smime.p7s
	438
	439	")
	440	(insert (base64-encode-string signature) "\n")
	441	(goto-char (point-max))
	442	(insert (format "--%s--\n" boundary))
	443	(goto-char (point-max))))
	444
	445	(defun mml-smime-epg-encrypt (cont)
	446	(let ((inhibit-redisplay t)
	447	(context (epg-make-context 'CMS))
	448	(config (epg-configuration))
449	(recipients (message-options-get 'mml-smime-epg-recipients))
450	cipher signers
451	(boundary (mml-compute-boundary cont))
452	recipient-key)
453	(unless recipients
454	(setq recipients
455	(apply #'nconc
456	(mapcar
457	(lambda (recipient)
458	(or (epg-expand-group config recipient)
459	(list recipient)))
460	(split-string
461	(or (message-options-get 'message-recipients)
462	(message-options-set 'message-recipients
463	(read-string "Recipients: ")))
464	"[ \f\t\n\r\v,]+"))))
54c72c31	465	(if (eq mm-encrypt-option 'guided)
01c52d31 MB	466	(setq recipients
	467	(epa-select-keys context "\
	468	Select recipients for encryption.
	469	If no one is selected, symmetric encryption will be performed. "
	470	recipients))
	471	(setq recipients
	472	(mapcar
	473	(lambda (recipient)
	474	(setq recipient-key (mml-smime-epg-find-usable-key
	475	(epg-list-keys context recipient)
	476	'encrypt))
	477	(unless (or recipient-key
	478	(y-or-n-p
	479	(format "No public key for %s; skip it? "
	480	recipient)))
	481	(error "No public key for %s" recipient))
	482	recipient-key)
	483	recipients))
	484	(unless recipients
	485	(error "No recipient specified")))
	486	(message-options-set 'mml-smime-epg-recipients recipients))
	487	(if mml-smime-cache-passphrase
	488	(epg-context-set-passphrase-callback
	489	context
	490	#'mml-smime-epg-passphrase-callback))
	491	(condition-case error
	492	(setq cipher
	493	(epg-encrypt-string context (buffer-string) recipients)
	494	mml-smime-epg-secret-key-id-list nil)
	495	(error
	496	(while mml-smime-epg-secret-key-id-list
	497	(password-cache-remove (car mml-smime-epg-secret-key-id-list))
	498	(setq mml-smime-epg-secret-key-id-list
	499	(cdr mml-smime-epg-secret-key-id-list)))
	500	(signal (car error) (cdr error))))
	501	(delete-region (point-min) (point-max))
	502	(goto-char (point-min))
	503	(insert "\
	504	Content-Type: application/pkcs7-mime;
	505	smime-type=enveloped-data;
	506	name=smime.p7m
	507	Content-Transfer-Encoding: base64
	508	Content-Disposition: attachment; filename=smime.p7m
	509
	510	")
	511	(insert (base64-encode-string cipher))
	512	(goto-char (point-max))))
	513
	514	(defun mml-smime-epg-verify (handle ctl)
	515	(catch 'error
	516	(let ((inhibit-redisplay t)
	517	context plain signature-file part signature)
	518	(when (or (null (setq part (mm-find-raw-part-by-type
	519	ctl (or (mm-handle-multipart-ctl-parameter
	520	ctl 'protocol)
	521	"application/pkcs7-signature")
	522	t)))
86fb1061 KY	523	(null (setq signature (or (mm-find-part-by-type
	524	(cdr handle)
	525	"application/pkcs7-signature"
	526	nil t)
	527	(mm-find-part-by-type
	528	(cdr handle)
	529	"application/x-pkcs7-signature"
	530	nil t)))))
01c52d31 MB	531	(mm-set-handle-multipart-parameter
	532	mm-security-handle 'gnus-info "Corrupted")
	533	(throw 'error handle))
0f3de88f	534	(setq part (mm-replace-in-string part "\n" "\r\n")
01c52d31 MB	535	context (epg-make-context 'CMS))
	536	(condition-case error
	537	(setq plain (epg-verify-string context (mm-get-part signature) part))
	538	(error
	539	(mm-set-handle-multipart-parameter
	540	mm-security-handle 'gnus-info "Failed")
	541	(if (eq (car error) 'quit)
	542	(mm-set-handle-multipart-parameter
	543	mm-security-handle 'gnus-details "Quit.")
	544	(mm-set-handle-multipart-parameter
	545	mm-security-handle 'gnus-details (format "%S" error)))
	546	(throw 'error handle)))
	547	(mm-set-handle-multipart-parameter
	548	mm-security-handle 'gnus-info
	549	(epg-verify-result-to-string (epg-context-result-for context 'verify)))
	550	handle)))
	551
	552	(defun mml-smime-epg-verify-test (handle ctl)
	553	t)
	554
23f87bed MB	555	(provide 'mml-smime)
23f87bed MB	556
23f87bed	557	;;; mml-smime.el ends here