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

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