cgit.sxemacs.org Git - gnus/blob - contrib/ssl.el

   1 ;;; ssl.el --- ssl functions for emacsen without them builtin
   2 ;; Author: $Author: zsh $
   3 ;; Created: $Date: 2001/07/13 19:31:09 $
   4 ;; Version: $Revision: 1.2 $
   5 ;; Keywords: comm
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28
  29 (eval-when-compile (require 'cl))
  30 (require 'base64)
  31
  32 (eval-and-compile
  33   (condition-case ()
  34       (require 'custom)
  35     (error nil))
  36   (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
  37       nil ;; We've got what we needed
  38     ;; We have the old custom-library, hack around it!
  39     (defmacro defgroup (&rest args)
  40       nil)
  41     (defmacro defcustom (var value doc &rest args)
  42       (` (defvar (, var) (, value) (, doc))))))
  43
  44 (defgroup ssl nil
  45   "Support for `Secure Sockets Layer' encryption."
  46   :group 'comm)
  47
  48 (defcustom ssl-certificate-directory "~/.w3/certs/"
  49   "*Directory to store CA certificates in"
  50   :group 'ssl
  51   :type 'directory)
  52
  53 (defcustom ssl-rehash-program-name "c_rehash"
  54   "*Program to run after adding a cert to a directory .
  55 Run with one argument, the directory name."
  56   :group 'ssl
  57   :type 'string)
  58
  59 (defcustom ssl-view-certificate-program-name "x509"
  60   "*The program to run to provide a human-readable view of a certificate."
  61   :group 'ssl
  62   :type 'string)
  63
  64 (defcustom ssl-view-certificate-program-arguments '("-text" "-inform" "DER")
  65   "*Arguments that should be passed to the certificate viewing program.
  66 The certificate is piped to it.
  67 Maybe a way of passing a file should be implemented"
  68   :group 'ssl
  69   :type 'list)
  70
  71 (defcustom ssl-certificate-directory-style 'ssleay
  72   "*Style of cert database to use, the only valid value right now is `ssleay'.
  73 This means a directory of pem encoded certificates with hash symlinks."
  74   :group 'ssl
  75   :type '(choice (const :tag "SSLeay" :value ssleay)
  76                  (const :tag "OpenSSL" :value openssl)))
  77
  78 (defcustom ssl-certificate-verification-policy 0
  79   "*How far up the certificate chain we should verify."
  80   :group 'ssl
  81   :type '(choice (const :tag "No verification" :value 0)
  82                  (const :tag "Verification required" :value 1)
  83                  (const :tag "Reject connection if verification fails" :value 3)
  84                  (const :tag "SSL_VERIFY_CLIENT_ONCE" :value 5)))
  85
  86 (defcustom ssl-program-name "openssl"
  87   "*The program to run in a subprocess to open an SSL connection."
  88   :group 'ssl
  89   :type 'string)
  90
  91 (defcustom ssl-program-arguments
  92   '("s_client"
  93     "-quiet"
  94     "-host" host
  95     "-port" service
  96     "-verify" (int-to-string ssl-certificate-verification-policy)
  97     "-CApath" ssl-certificate-directory
  98     )
  99   "*Arguments that should be passed to the program `ssl-program-name'.
 100 This should be used if your SSL program needs command line switches to
 101 specify any behaviour (certificate file locations, etc).
 102 The special symbols 'host and 'port may be used in the list of arguments
 103 and will be replaced with the hostname and service/port that will be connected
 104 to."
 105   :group 'ssl
 106   :type 'list)
 107
 108 (defun ssl-certificate-information (der)
 109   "Return an assoc list of information about a certificate in DER format."
 110   (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n"
 111                              (base64-encode-string der)
 112                              "\n-----END CERTIFICATE-----\n"))
 113         (exit-code 0))
 114     (save-excursion
 115       (set-buffer (get-buffer-create " *openssl*"))
 116       (erase-buffer)
 117       (insert certificate)
 118       (setq exit-code (condition-case ()
 119                           (call-process-region (point-min) (point-max)
 120                                                ssl-program-name
 121                                                t (list (current-buffer) nil) t
 122                                                "x509"
 123                                                "-subject" ; Print the subject DN
 124                                                "-issuer" ; Print the issuer DN
 125                                                "-dates" ; Both before and after dates
 126                                                "-serial" ; print out serial number
 127                                                "-noout" ; Don't spit out the certificate
 128                                                )
 129                         (error -1)))
 130       (if (/= exit-code 0)
 131           nil
 132         (let ((vals nil))
 133           (goto-char (point-min))
 134           (while (re-search-forward "^\\([^=\n\r]+\\)\\s *=\\s *\\(.*\\)" nil t)
 135             (push (cons (match-string 1) (match-string 2)) vals))
 136           vals)))))
 137
 138 (defun ssl-accept-ca-certificate ()
 139   "Ask if the user is willing to accept a new CA certificate. The buffer-name
 140 should be the intended name of the certificate, and the buffer should probably
 141 be in DER encoding"
 142   ;; TODO, check if it is really new or if we already know it
 143   (let* ((process-connection-type nil)
 144          (tmpbuf (generate-new-buffer "X509 CA Certificate Information"))
 145          (response (save-excursion
 146                      (and (eq 0
 147                               (apply 'call-process-region
 148                                      (point-min) (point-max)
 149                                      ssl-view-certificate-program-name
 150                                      nil tmpbuf t
 151                                      ssl-view-certificate-program-arguments))
 152                           (switch-to-buffer tmpbuf)
 153                           (goto-char (point-min))
 154                           (or (recenter) t)
 155                           (yes-or-no-p
 156                            "Accept this CA to vouch for secure server identities? ")
 157                           (kill-buffer tmpbuf)))))
 158     (if (not response)
 159         nil
 160       (if (not (file-directory-p ssl-certificate-directory))
 161           (make-directory ssl-certificate-directory))
 162       (case ssl-certificate-directory-style
 163         (ssleay
 164          (base64-encode-region (point-min) (point-max))
 165          (goto-char (point-min))
 166          (insert "-----BEGIN CERTIFICATE-----\n")
 167          (goto-char (point-max))
 168          (insert "-----END CERTIFICATE-----\n")
 169          (let ((f (expand-file-name
 170                    (concat (file-name-sans-extension (buffer-name)) ".pem")
 171                    ssl-certificate-directory)))
 172            (write-file f)
 173            (call-process ssl-rehash-program-name
 174                          nil nil nil
 175                          (expand-file-name ssl-certificate-directory))))))))
 176
 177 (defun open-ssl-stream (name buffer host service)
 178   "Open a SSL connection for a service to a host.
 179 Returns a subprocess-object to represent the connection.
 180 Input and output work as for subprocesses; `delete-process' closes it.
 181 Args are NAME BUFFER HOST SERVICE.
 182 NAME is name for process.  It is modified if necessary to make it unique.
 183 BUFFER is the buffer (or buffer-name) to associate with the process.
 184  Process output goes at end of that buffer, unless you specify
 185  an output stream or filter function to handle the output.
 186  BUFFER may be also nil, meaning that this process is not associated
 187  with any buffer
 188 Third arg is name of the host to connect to, or its IP address.
 189 Fourth arg SERVICE is name of the service desired, or an integer
 190 specifying a port number to connect to."
 191   (if (integerp service) (setq service (int-to-string service)))
 192   (let* ((process-connection-type nil)
 193          (port service)
 194          (proc (eval
 195                 (`
 196                  (start-process name buffer ssl-program-name
 197                                 (,@ ssl-program-arguments))))))
 198     (process-kill-without-query proc)
 199     proc))
 200
 201 (provide 'ssl)