1;;; ssl.el,v --- ssl functions for emacsen without them builtin  -*- lexical-binding: t -*-
2;; Author: wmperry
3;; Created: 1999/10/14 12:44:18
4;; Version: 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(require 'cl-lib)
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 to store CA certificates in"
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 .
42Run 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.
53The certificate is piped to it.
54Maybe a way of passing a file should be implemented"
55  :group 'ssl
56  :type 'list)
57
58(defcustom ssl-certificate-directory-style 'ssleay
59  "*Style of cert database to use, the only valid value right now is `ssleay'.
60This 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  "*Arguments that should be passed to the program `ssl-program-name'.
86This should be used if your SSL program needs command line switches to
87specify any behaviour (certificate file locations, etc).
88The special symbols 'host and 'service may be used in the list of arguments
89and will be replaced with the hostname and service/port that will be connected
90to."
91  :group 'ssl
92  :type 'list)
93
94(defun ssl-certificate-information (der)
95  "Return an assoc list of information about a certificate in DER format."
96  (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n"
97			     (base64-encode-string der)
98			     "\n-----END CERTIFICATE-----\n"))
99	(exit-code 0))
100    (with-current-buffer (get-buffer-create " *openssl*")
101      (erase-buffer)
102      (insert certificate)
103      (setq exit-code (condition-case ()
104			  (call-process-region (point-min) (point-max)
105					       ssl-program-name
106					       t (list (current-buffer) nil) t
107					       "x509"
108					       "-subject" ; Print the subject DN
109					       "-issuer" ; Print the issuer DN
110					       "-dates" ; Both before and after dates
111					       "-serial" ; print out serial number
112					       "-noout" ; Don't spit out the certificate
113					       )
114			(error -1)))
115      (if (/= exit-code 0)
116	  nil
117	(let ((vals nil))
118	  (goto-char (point-min))
119	  (while (re-search-forward "^\\([^=\n\r]+\\)\\s *=\\s *\\(.*\\)" nil t)
120	    (push (cons (match-string 1) (match-string 2)) vals))
121	  vals)))))
122
123(defun ssl-accept-ca-certificate ()
124  "Ask if the user is willing to accept a new CA certificate. The buffer-name
125should be the intended name of the certificate, and the buffer should probably
126be in DER encoding"
127  ;; TODO, check if it is really new or if we already know it
128  (let* ((process-connection-type nil)
129	 (tmpbuf (generate-new-buffer "X509 CA Certificate Information"))
130	 (response (save-excursion
131		     (and (eq 0
132			      (apply 'call-process-region
133				     (point-min) (point-max)
134				     ssl-view-certificate-program-name
135				     nil tmpbuf t
136				     ssl-view-certificate-program-arguments))
137			  (switch-to-buffer tmpbuf)
138			  (goto-char (point-min))
139			  (or (recenter) t)
140			  (yes-or-no-p
141			   "Accept this CA to vouch for secure server identities? ")
142			  (kill-buffer tmpbuf)))))
143    (if (not response)
144	nil
145      (if (not (file-directory-p ssl-certificate-directory))
146	  (make-directory ssl-certificate-directory))
147      (cl-case ssl-certificate-directory-style
148	(ssleay
149	 (base64-encode-region (point-min) (point-max))
150	 (goto-char (point-min))
151	 (insert "-----BEGIN CERTIFICATE-----\n")
152	 (goto-char (point-max))
153	 (insert "-----END CERTIFICATE-----\n")
154	 (let ((f (expand-file-name
155		   (concat (file-name-sans-extension (buffer-name)) ".pem")
156		   ssl-certificate-directory)))
157	   (write-file f)
158	   (call-process ssl-rehash-program-name
159			 nil nil nil
160			 (expand-file-name ssl-certificate-directory))))))))
161
162(defun open-ssl-stream (name buffer host service)
163  "Open a SSL connection for a service to a host.
164Returns a subprocess-object to represent the connection.
165Input and output work as for subprocesses; `delete-process' closes it.
166Args are NAME BUFFER HOST SERVICE.
167NAME is name for process.  It is modified if necessary to make it unique.
168BUFFER is the buffer (or buffer-name) to associate with the process.
169 Process output goes at end of that buffer, unless you specify
170 an output stream or filter function to handle the output.
171 BUFFER may be also nil, meaning that this process is not associated
172 with any buffer
173Third arg is name of the host to connect to, or its IP address.
174Fourth arg SERVICE is name of the service desired, or an integer
175specifying a port number to connect to."
176  (if (integerp service) (setq service (number-to-string service)))
177  (let* ((process-connection-type nil)
178	 (proc (apply 'start-process name buffer ssl-program-name
179		      (mapcar (lambda (elt)
180				(eval `(let ((host ,host)
181					     (service ,service))
182					 ,elt)))
183			      ssl-program-arguments))))
184    (set-process-query-on-exit-flag proc nil)
185    proc))
186
187(provide 'ssl)
188