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

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

;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008, 2009, 2010, 2011 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")

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