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