Synch to No Gnus 200602220940.
authoryamaoka <yamaoka>
Wed, 22 Feb 2006 09:43:29 +0000 (09:43 +0000)
committeryamaoka <yamaoka>
Wed, 22 Feb 2006 09:43:29 +0000 (09:43 +0000)
contrib/smime-card.el [new file with mode: 0644]

diff --git a/contrib/smime-card.el b/contrib/smime-card.el
new file mode 100644 (file)
index 0000000..e76bca4
--- /dev/null
@@ -0,0 +1,196 @@
+;;; smime-card.el --- Make smime.el work with card readers
+
+;; Copyright (C) 2005 Brailcom, o.p.s.
+;; Author: Milan Zamazal <pdm@zamazal.org>
+
+;; 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