contrib/smime-card.el

   1 ;;; smime-card.el --- Make smime.el work with card readers
   2
   3 ;; Copyright (C) 2005 Brailcom, o.p.s.
   4 ;; Author: Milan Zamazal <pdm@zamazal.org>
   5
   6 ;; COPYRIGHT NOTICE
   7 ;;
   8 ;; This program is free software; you can redistribute it and/or modify it
   9 ;; under the terms of the GNU General Public License as published by the Free
  10 ;; Software Foundation; either version 2, or (at your option) any later
  11 ;; version.
  12 ;;
  13 ;; This program is distributed in the hope that it will be useful, but
  14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  15 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 ;; for more details.
  17 ;;
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This is a simple wrapper around smime.el allowing to use private keys stored
  24 ;; on a smard card.
  25 ;;
  26 ;; To use it, just put (require 'smime-card) to you Emacs startup file and
  27 ;; customize the variable `smime-card-file-keys'.
  28
  29 ;;; Code:
  30
  31 (require 'smime)
  32
  33 ;;; Configuration
  34
  35 (defcustom smime-card-file-keys '()
  36   "Alist of certificate files and their corresponding private key card ids.
  37 Each element of the list is of the form (FILE . KEY-ID), where FILE is a
  38 certificate file stored on a regular file system and KEY-ID is the identifier
  39 of the corresponding private key stored on the card.
  40 If FILE begins with the prefix `card:', the certificate is retrieved from the
  41 card under the id following the `card:' prefix in FILE."
  42   :type '(alist :key-type (file :tag "Certificate file")
  43                 :value-type (string :tag "Key identifier"))
  44   :group 'smime)
  45
  46 (defcustom smime-card-fetch-certificates nil
  47   "If non-nil, fetch certificates from the card before verifying messages."
  48   :type 'boolean
  49   :group 'smime)
  50
  51 ;;; Internals
  52
  53 (defvar smime-card-key nil)
  54
  55 (defun smime-card-key (keyfile)
  56   (cdr (assoc keyfile smime-card-file-keys)))
  57
  58 (defvar smime-card-engine-command
  59   "engine dynamic -pre SO_PATH:/usr/lib/opensc/engine_pkcs11.so -pre ID:pkcs11 -pre LIST_ADD:1 -pre LOAD\n")
  60
  61 (defvar smime-card-process-output "")
  62
  63 (defun smime-card-process-filter (process string)
  64   (setq smime-card-process-output (concat smime-card-process-output string)))
  65
  66 (defun smime-card-wait-for-prompt (process)
  67   (while (not (string-match "\\(OpenSSL> \\|PIN: \\)$"
  68                             smime-card-process-output))
  69     (unless (accept-process-output process 5)
  70       (message "OpenSSL: Timeout")
  71       (throw 'error nil)))
  72   (prog1 (if (string= (match-string 1 smime-card-process-output) "PIN: ")
  73              'pin
  74            t)
  75     (setq smime-card-process-output "")))
  76
  77 (defun smime-card-call-openssl-region (b e buf &rest args)
  78   (let* ((infile (make-temp-file "smime-card-in"))
  79          (outfile (make-temp-file "smime-card-out"))
  80          (cert-on-card (and (string-match "^card:\\(.*\\)$" keyfile)
  81                             (match-string 1 keyfile)))
  82          (certfile (and cert-on-card (make-temp-file "smime-card-cert")))
  83          (args (append args
  84                        (list "-engine" "pkcs11"
  85                              "-keyform" "engine"
  86                              "-inkey" smime-card-key
  87                              "-in" infile "-out" outfile)))
  88          (process (start-process "openssl" " *openssl*" smime-openssl-program)))
  89     (unwind-protect
  90         (catch 'error
  91           (when certfile
  92             (unless (= (call-process "pkcs15-tool" nil nil nil
  93                                      "-r" cert-on-card "-o" certfile)
  94                        0)
  95               (message "pkcs15: Error")
  96               (throw 'error nil))
  97             (let ((args* args))
  98               (while (and args* (not (string= (car args*) "-signer")))
  99                 (setq args* (cdr args*)))
 100               (setq args* (cdr args*))
 101               (when args*
 102                 (setcar args* certfile))))
 103           (setq smime-card-process-output "")
 104           (set-process-filter process 'smime-card-process-filter)
 105           (unless (eq (smime-card-wait-for-prompt process) t)
 106             (message "OpenSSL: Error on startup")
 107             (throw 'error nil))
 108           (process-send-string process smime-card-engine-command)
 109           (unless (eq (smime-card-wait-for-prompt process) t)
 110             (message "OpenSSL: Error in pkcs11 loading")
 111             (throw 'error nil))
 112           (write-region b e infile nil 0)
 113           (process-send-string process
 114                                (concat (mapconcat 'identity args " ") "\n"))
 115           (let ((answer (smime-card-wait-for-prompt process)))
 116             (cond
 117              ((eq answer 'pin)
 118               (process-send-string process (concat (read-passwd "Smartcard PIN: ") "\n"))
 119               (unless (eq (smime-card-wait-for-prompt process) t)
 120                 (message "OpenSSL: Error after passphrase")
 121                 (throw 'error nil)))
 122              ((eq answer t)
 123               nil)
 124              (t
 125               (message "OpenSSL: Error in processing")
 126               (throw 'error nil))))
 127           (process-send-eof process)
 128           (with-current-buffer (car buf)
 129             (when (= (cadr (insert-file-contents outfile)) 0)
 130               (message "OpenSSL: Empty output")
 131               (throw 'error nil)))
 132           t)
 133       (delete-file infile)
 134       (delete-file outfile)
 135       (when certfile (delete-file certfile))
 136       (delete-process process)
 137       (kill-buffer " *openssl*"))))
 138
 139 ;;; smime.el advices
 140
 141 (defadvice smime-sign-region (around smime-card-sign-region activate)
 142   (let ((smime-card-key (smime-card-key (ad-get-arg 2))))
 143     ad-do-it))
 144
 145 (defadvice smime-decrypt-region (around smime-card-decrypt-region activate)
 146   (let ((smime-card-key (smime-card-key (ad-get-arg 2))))
 147     ad-do-it))
 148
 149 (defadvice smime-call-openssl-region (around smime-card-openssl activate)
 150   (if smime-card-key
 151       (setq ad-return-value
 152             (apply 'smime-card-call-openssl-region (ad-get-args 0)))
 153     ad-do-it))
 154
 155 (defadvice smime-verify-region (around smime-card-verify-region activate)
 156   (if smime-card-fetch-certificates
 157       (let ((cert-ids '()))
 158         (with-temp-buffer
 159           (unless (= (call-process
 160                       "pkcs15-tool" nil t nil "--list-certificates")
 161                      0)
 162             (error "pkcs15: Certificate listing"))
 163           (goto-char (point-min))
 164           (while (re-search-forward "^[\t ]+ID[ ]+: \\([0-9]+\\) *$" nil t)
 165             (setq cert-ids (cons (match-string 1) cert-ids))))
 166         (let ((certfile (make-temp-file "smime-card")))
 167           (unwind-protect
 168               (progn
 169                 (with-temp-file certfile
 170                   (when smime-CA-file
 171                     (insert-file-contents smime-CA-file))
 172                   (mapc (lambda (id)
 173                           (unless (= (call-process "pkcs15-tool" nil t nil
 174                                                    "-r" id)
 175                                      0)
 176                             (error "pkcs15: Certificat read")))
 177                         cert-ids))
 178                 (let ((smime-CA-file certfile))
 179                   ad-do-it))
 180             (delete-file certfile))))
 181     ad-do-it))
 182
 183 (defadvice mml-smime-verify (around smime-card-mml-smime-verify activate)
 184   ;; If both smime-CA-directory and smime-CA-file are unset, `mml-smime-verify'
 185   ;; refuses to perform certificate verification.
 186   (let ((smime-CA-file (if smime-card-fetch-certificates
 187                            (or smime-CA-file "/dev/null")
 188                          smime-CA-file)))
 189     ad-do-it))
 190
 191 ;;; Announce
 192
 193 (provide 'smime-card)
 194
 195 ;;; smime-card.el ends here