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