[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.
(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-verbose mml-secure-verbose
  "If non-nil, ask the user about the current operation more verbosely."
  :group 'mime-security
  :type 'boolean)

(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
  "If t, cache passphrase."
  :group 'mime-security
  :type 'boolean)

(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
  "How many seconds the passphrase is cached.
Whether the passphrase is cached at all is controlled by
`mml-smime-cache-passphrase'."
  :group 'mime-security
  :type 'integer)

(defcustom mml-smime-signers nil
  "A list of your own key ID which will be used to sign a message."
  :group 'mime-security
  :type '(repeat (string :tag "Key ID")))

(defun mml-smime-sign (cont)
  (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func cont)
      (error "Cannot find sign function"))))

(defun mml-smime-encrypt (cont)
  (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func cont)
      (error "Cannot find encrypt function"))))

(defun mml-smime-sign-query ()
  (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func))))

(defun mml-smime-encrypt-query ()
  (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func))))

(defun mml-smime-verify (handle ctl)
  (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func handle ctl)
      handle)))

(defun mml-smime-verify-test (handle ctl)
  (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
    (if func
	(funcall func handle ctl))))

(defun mml-smime-openssl-sign (cont)
  (when (null smime-keys)
    (customize-variable 'smime-keys)
    (error "No S/MIME keys configured, use customize to add your key"))
  (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
	       (completing-read "Sign this part with what signature? "
				smime-keys 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-with-default "gnus-util")

(defun mml-smime-openssl-encrypt-query ()
  ;; todo: try dns/ldap automatically first, before prompting user
  (let (certs done)
    (while (not done)
      (ecase (read (gnus-completing-read-with-default
		    "ldap" "Fetch certificate from"
		    '(("dns") ("ldap") ("file")) nil t))
	(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 (mm-find-part-by-type
				       (cdr handle)
				       "application/pkcs7-signature"
				       nil t))))
	(mm-set-handle-multipart-parameter
	 mm-security-handle 'gnus-info "Corrupted")
	(throw 'error handle))
      (setq 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)

;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
;;; 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
431e6df6 GM	28	;; For Emacs < 22.2.
	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
	56	(defcustom mml-smime-verbose mml-secure-verbose
	57	"If non-nil, ask the user about the current operation more verbosely."
	58	:group 'mime-security
	59	:type 'boolean)
	60
	61	(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
	62	"If t, cache passphrase."
	63	:group 'mime-security
	64	:type 'boolean)
	65
	66	(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
	67	"How many seconds the passphrase is cached.
	68	Whether the passphrase is cached at all is controlled by
	69	`mml-smime-cache-passphrase'."
	70	:group 'mime-security
	71	:type 'integer)
	72
	73	(defcustom mml-smime-signers nil
	74	"A list of your own key ID which will be used to sign a message."
	75	:group 'mime-security
	76	:type '(repeat (string :tag "Key ID")))
	77
23f87bed	78	(defun mml-smime-sign (cont)
01c52d31 MB	79	(let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
	80	(if func
	81	(funcall func cont)
	82	(error "Cannot find sign function"))))
	83
	84	(defun mml-smime-encrypt (cont)
	85	(let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
	86	(if func
	87	(funcall func cont)
	88	(error "Cannot find encrypt function"))))
	89
	90	(defun mml-smime-sign-query ()
	91	(let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
	92	(if func
	93	(funcall func))))
	94
	95	(defun mml-smime-encrypt-query ()
	96	(let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
	97	(if func
	98	(funcall func))))
	99
	100	(defun mml-smime-verify (handle ctl)
	101	(let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
	102	(if func
	103	(funcall func handle ctl)
	104	handle)))
	105
	106	(defun mml-smime-verify-test (handle ctl)
	107	(let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
	108	(if func
	109	(funcall func handle ctl))))
	110
	111	(defun mml-smime-openssl-sign (cont)
23f87bed MB	112	(when (null smime-keys)
	113	(customize-variable 'smime-keys)
	114	(error "No S/MIME keys configured, use customize to add your key"))
	115	(smime-sign-buffer (cdr (assq 'keyfile cont)))
	116	(goto-char (point-min))
	117	(while (search-forward "\r\n" nil t)
	118	(replace-match "\n" t t))
	119	(goto-char (point-max)))
	120
01c52d31	121	(defun mml-smime-openssl-encrypt (cont)
23f87bed MB	122	(let (certnames certfiles tmp file tmpfiles)
	123	;; xxx tmp files are always an security issue
	124	(while (setq tmp (pop cont))
	125	(if (and (consp tmp) (eq (car tmp) 'certfile))
	126	(push (cdr tmp) certnames)))
	127	(while (setq tmp (pop certnames))
	128	(if (not (and (not (file-exists-p tmp))
	129	(get-buffer tmp)))
	130	(push tmp certfiles)
8d1d11d8	131	(setq file (mm-make-temp-file (expand-file-name "mml."
23f87bed MB	132	mm-tmp-directory)))
	133	(with-current-buffer tmp
	134	(write-region (point-min) (point-max) file))
	135	(push file certfiles)
	136	(push file tmpfiles)))
	137	(if (smime-encrypt-buffer certfiles)
	138	(progn
	139	(while (setq tmp (pop tmpfiles))
	140	(delete-file tmp))
	141	t)
	142	(while (setq tmp (pop tmpfiles))
	143	(delete-file tmp))
	144	nil))
	145	(goto-char (point-max)))
	146
ec374c91 GM	147	(defvar gnus-extract-address-components)
ec374c91 GM	148
01c52d31	149	(defun mml-smime-openssl-sign-query ()
23f87bed MB	150	;; query information (what certificate) from user when MML tag is
	151	;; added, for use later by the signing process
	152	(when (null smime-keys)
	153	(customize-variable 'smime-keys)
	154	(error "No S/MIME keys configured, use customize to add your key"))
	155	(list 'keyfile
	156	(if (= (length smime-keys) 1)
	157	(cadar smime-keys)
4a2358e9 MB	158	(or (let ((from (cadr (funcall (if (boundp
	159	'gnus-extract-address-components)
	160	gnus-extract-address-components
	161	'mail-extract-address-components)
23f87bed MB	162	(or (save-excursion
	163	(save-restriction
	164	(message-narrow-to-headers)
	165	(message-fetch-field "from")))
	166	"")))))
	167	(and from (smime-get-key-by-email from)))
	168	(smime-get-key-by-email
	169	(completing-read "Sign this part with what signature? "
	170	smime-keys nil nil
	171	(and (listp (car-safe smime-keys))
	172	(caar smime-keys))))))))
	173
	174	(defun mml-smime-get-file-cert ()
	175	(ignore-errors
	176	(list 'certfile (read-file-name
	177	"File with recipient's S/MIME certificate: "
	178	smime-certificate-directory nil t ""))))
	179
	180	(defun mml-smime-get-dns-cert ()
	181	;; todo: deal with comma separated multiple recipients
	182	(let (result who bad cert)
	183	(condition-case ()
	184	(while (not result)
	185	(setq who (read-from-minibuffer
	186	(format "%sLookup certificate for: " (or bad ""))
4a2358e9 MB	187	(cadr (funcall (if (boundp
	188	'gnus-extract-address-components)
	189	gnus-extract-address-components
	190	'mail-extract-address-components)
23f87bed MB	191	(or (save-excursion
	192	(save-restriction
	193	(message-narrow-to-headers)
	194	(message-fetch-field "to")))
	195	"")))))
	196	(if (setq cert (smime-cert-by-dns who))
	197	(setq result (list 'certfile (buffer-name cert)))
	198	(setq bad (format "`%s' not found. " who))))
	199	(quit))
	200	result))
	201
01c52d31 MB	202	(defun mml-smime-get-ldap-cert ()
	203	;; todo: deal with comma separated multiple recipients
	204	(let (result who bad cert)
	205	(condition-case ()
	206	(while (not result)
	207	(setq who (read-from-minibuffer
	208	(format "%sLookup certificate for: " (or bad ""))
	209	(cadr (funcall gnus-extract-address-components
	210	(or (save-excursion
	211	(save-restriction
	212	(message-narrow-to-headers)
	213	(message-fetch-field "to")))
	214	"")))))
	215	(if (setq cert (smime-cert-by-ldap who))
	216	(setq result (list 'certfile (buffer-name cert)))
	217	(setq bad (format "`%s' not found. " who))))
	218	(quit))
	219	result))
	220
431e6df6 GM	221	(autoload 'gnus-completing-read-with-default "gnus-util")
431e6df6 GM	222
01c52d31	223	(defun mml-smime-openssl-encrypt-query ()
23f87bed MB	224	;; todo: try dns/ldap automatically first, before prompting user
	225	(let (certs done)
	226	(while (not done)
	227	(ecase (read (gnus-completing-read-with-default
01c52d31 MB	228	"ldap" "Fetch certificate from"
01c52d31 MB	229	'(("dns") ("ldap") ("file")) nil t))
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)))
	523	(null (setq signature (mm-find-part-by-type
	524	(cdr handle)
	525	"application/pkcs7-signature"
	526	nil t))))
	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
cbee283d	553	;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
23f87bed	554	;;; mml-smime.el ends here