From: yamaoka Date: Wed, 22 Feb 2006 09:43:29 +0000 (+0000) Subject: Synch to No Gnus 200602220940. X-Git-Tag: t-gnus-6_17_4-quimby-~81 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=c6462d3c2dd3182f9bffc17cf58fae2ba726eefa;p=elisp%2Fgnus.git- Synch to No Gnus 200602220940. --- diff --git a/contrib/smime-card.el b/contrib/smime-card.el new file mode 100644 index 0000000..e76bca4 --- /dev/null +++ b/contrib/smime-card.el @@ -0,0 +1,196 @@ +;;; smime-card.el --- Make smime.el work with card readers + +;; Copyright (C) 2005 Brailcom, o.p.s. +;; Author: Milan Zamazal + +;; COPYRIGHT NOTICE +;; +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2, or (at your option) any later +;; version. +;; +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: + +;; This is a simple wrapper around smime.el allowing to use private keys stored +;; on a smard card. +;; +;; To use it, just put (require 'smime-card) to you Emacs startup file and +;; customize the variable `smime-card-file-keys'. + +;;; Code: + +(require 'smime) + +;;; Configuration + +(defcustom smime-card-file-keys '() + "Alist of certificate files and their corresponding private key card ids. +Each element of the list is of the form (FILE . KEY-ID), where FILE is a +certificate file stored on a regular file system and KEY-ID is the identifier +of the corresponding private key stored on the card. +If FILE begins with the prefix `card:', the certificate is retrieved from the +card under the id following the `card:' prefix in FILE." + :type '(alist :key-type (file :tag "Certificate file") + :value-type (string :tag "Key identifier")) + :group 'smime) + +(defcustom smime-card-fetch-certificates nil + "If non-nil, fetch certificates from the card before verifying messages." + :type 'boolean + :group 'smime) + +;;; Internals + +(defvar smime-card-key nil) + +(defun smime-card-key (keyfile) + (cdr (assoc keyfile smime-card-file-keys))) + +(defvar smime-card-engine-command + "engine dynamic -pre SO_PATH:/usr/lib/opensc/engine_pkcs11.so -pre ID:pkcs11 -pre LIST_ADD:1 -pre LOAD\n") + +(defvar smime-card-process-output "") + +(defun smime-card-process-filter (process string) + (setq smime-card-process-output (concat smime-card-process-output string))) + +(defun smime-card-wait-for-prompt (process) + (while (not (string-match "\\(OpenSSL> \\|PIN: \\)$" + smime-card-process-output)) + (unless (accept-process-output process 5) + (message "OpenSSL: Timeout") + (throw 'error nil))) + (prog1 (if (string= (match-string 1 smime-card-process-output) "PIN: ") + 'pin + t) + (setq smime-card-process-output ""))) + +(defun smime-card-call-openssl-region (b e buf &rest args) + (let* ((infile (make-temp-file "smime-card-in")) + (outfile (make-temp-file "smime-card-out")) + (cert-on-card (and (string-match "^card:\\(.*\\)$" keyfile) + (match-string 1 keyfile))) + (certfile (and cert-on-card (make-temp-file "smime-card-cert"))) + (args (append args + (list "-engine" "pkcs11" + "-keyform" "engine" + "-inkey" smime-card-key + "-in" infile "-out" outfile))) + (process (start-process "openssl" " *openssl*" smime-openssl-program))) + (unwind-protect + (catch 'error + (when certfile + (unless (= (call-process "pkcs15-tool" nil nil nil + "-r" cert-on-card "-o" certfile) + 0) + (message "pkcs15: Error") + (throw 'error nil)) + (let ((args* args)) + (while (and args* (not (string= (car args*) "-signer"))) + (setq args* (cdr args*))) + (setq args* (cdr args*)) + (when args* + (setcar args* certfile)))) + (setq smime-card-process-output "") + (set-process-filter process 'smime-card-process-filter) + (unless (eq (smime-card-wait-for-prompt process) t) + (message "OpenSSL: Error on startup") + (throw 'error nil)) + (process-send-string process smime-card-engine-command) + (unless (eq (smime-card-wait-for-prompt process) t) + (message "OpenSSL: Error in pkcs11 loading") + (throw 'error nil)) + (write-region b e infile nil 0) + (process-send-string process + (concat (mapconcat 'identity args " ") "\n")) + (let ((answer (smime-card-wait-for-prompt process))) + (cond + ((eq answer 'pin) + (process-send-string process (concat (read-passwd "Smartcard PIN: ") "\n")) + (unless (eq (smime-card-wait-for-prompt process) t) + (message "OpenSSL: Error after passphrase") + (throw 'error nil))) + ((eq answer t) + nil) + (t + (message "OpenSSL: Error in processing") + (throw 'error nil)))) + (process-send-eof process) + (with-current-buffer (car buf) + (when (= (cadr (insert-file-contents outfile)) 0) + (message "OpenSSL: Empty output") + (throw 'error nil))) + t) + (delete-file infile) + (delete-file outfile) + (when certfile (delete-file certfile)) + (delete-process process) + (kill-buffer " *openssl*")))) + +;;; smime.el advices + +(defadvice smime-sign-region (around smime-card-sign-region activate) + (let ((smime-card-key (smime-card-key (ad-get-arg 2)))) + ad-do-it)) + +(defadvice smime-decrypt-region (around smime-card-decrypt-region activate) + (let ((smime-card-key (smime-card-key (ad-get-arg 2)))) + ad-do-it)) + +(defadvice smime-call-openssl-region (around smime-card-openssl activate) + (if smime-card-key + (setq ad-return-value + (apply 'smime-card-call-openssl-region (ad-get-args 0))) + ad-do-it)) + +(defadvice smime-verify-region (around smime-card-verify-region activate) + (if smime-card-fetch-certificates + (let ((cert-ids '())) + (with-temp-buffer + (unless (= (call-process + "pkcs15-tool" nil t nil "--list-certificates") + 0) + (error "pkcs15: Certificate listing")) + (goto-char (point-min)) + (while (re-search-forward "^[\t ]+ID[ ]+: \\([0-9]+\\) *$" nil t) + (setq cert-ids (cons (match-string 1) cert-ids)))) + (let ((certfile (make-temp-file "smime-card"))) + (unwind-protect + (progn + (with-temp-file certfile + (when smime-CA-file + (insert-file-contents smime-CA-file)) + (mapc (lambda (id) + (unless (= (call-process "pkcs15-tool" nil t nil + "-r" id) + 0) + (error "pkcs15: Certificat read"))) + cert-ids)) + (let ((smime-CA-file certfile)) + ad-do-it)) + (delete-file certfile)))) + ad-do-it)) + +(defadvice mml-smime-verify (around smime-card-mml-smime-verify activate) + ;; If both smime-CA-directory and smime-CA-file are unset, `mml-smime-verify' + ;; refuses to perform certificate verification. + (let ((smime-CA-file (if smime-card-fetch-certificates + (or smime-CA-file "/dev/null") + smime-CA-file))) + ad-do-it)) + +;;; Announce + +(provide 'smime-card) + +;;; smime-card.el ends here