<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"><HTML>1<HEAD>2<!-- hennerik CVSweb $Revision: 1.112 $ -->3<TITLE>gnus/contrib/ssl.el - view - 7.6</TITLE></HEAD>4<BODY BGCOLOR="#eeeeee">5<table width="100%" border=0 cellspacing=0 cellpadding=1 bgcolor="#9999ee"><tr valign=bottom><td><a href="ssl.el#rev7.6"><IMG SRC="/icons/back.gif" ALT="[BACK]" BORDER="0" WIDTH="20" HEIGHT="22"></a> <b>Return to <A HREF="ssl.el#rev7.6">ssl.el</A>6CVS log</b> <IMG SRC="/icons/text.gif" ALT="[TXT]" BORDER="0" WIDTH="20" HEIGHT="22"></td><td align=right><IMG SRC="/icons/dir.gif" ALT="[DIR]" BORDER="0" WIDTH="20" HEIGHT="22"> <b>Up to <a href="/cgi-bin/cvsweb.cgi/#dirlist">[(ding)]</a> / <a href="/cgi-bin/cvsweb.cgi/gnus/#dirlist">gnus</a> / <a href="/cgi-bin/cvsweb.cgi/gnus/contrib/#dirlist">contrib</a></b></td></tr></table><HR noshade><table width="100%"><tr><td bgcolor="#ffffff">File: <a href="/cgi-bin/cvsweb.cgi/#dirlist">[(ding)]</a> / <a href="/cgi-bin/cvsweb.cgi/gnus/#dirlist">gnus</a> / <a href="/cgi-bin/cvsweb.cgi/gnus/contrib/#dirlist">contrib</a> / <a href="/cgi-bin/cvsweb.cgi/gnus/contrib/ssl.el">ssl.el</a> (<A HREF="/cgi-bin/cvsweb.cgi/~checkout~/gnus/contrib/ssl.el?rev=7.6" target="cvs_checkout" onClick="window.open('/cgi-bin/cvsweb.cgi/~checkout~/gnus/contrib/ssl.el?rev=7.6','cvs_checkout','resizeable,scrollbars');"><b>download</b></A>)<BR>7Revision <B>7.6</B>, <i>Thu Dec 29 03:46:41 2005 UTC</i> (4 years, 5 months ago) by <i>miles</i>8<BR>CVS Tags: <b>n0-6, n0-5, n0-4</b><BR>Changes since <b>7.5: +2 -09lines</b><PRE>10Add arch tagline11</PRE>12</td></tr></table><HR noshade><PRE>;;; ssl.el,v --- ssl functions for Emacsen without them builtin13;; Author: William M. Perry <<A HREF="mailto:[email protected]">[email protected]</A>>14;; $Revision: 1.5 $15;; Keywords: comm1617;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;18;;; Copyright (c) 1995, 1996 by William M. Perry <<A HREF="mailto:[email protected]">[email protected]</A>>19;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc.20;;;21;;; This file is part of GNU Emacs.22;;;23;;; GNU Emacs is free software; you can redistribute it and/or modify24;;; it under the terms of the GNU General Public License as published by25;;; the Free Software Foundation; either version 2, or (at your option)26;;; any later version.27;;;28;;; GNU Emacs is distributed in the hope that it will be useful,29;;; but WITHOUT ANY WARRANTY; without even the implied warranty of30;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the31;;; GNU General Public License for more details.32;;;33;;; You should have received a copy of the GNU General Public License34;;; along with GNU Emacs; see the file COPYING. If not, write to the35;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,36;;; Boston, MA 02111-1307, USA.37;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;3839(eval-when-compile (require 'cl))40(require 'base64)41(require 'url) ; for `url-configuration-directory'4243(defgroup ssl nil44 "Support for `Secure Sockets Layer' encryption."45 :group 'comm)46 47(defcustom ssl-certificate-directory "~/.w3/certs/"48 "*Directory in which to store CA certificates."49 :group 'ssl50 :type 'directory)5152(defcustom ssl-rehash-program-name "c_rehash"53 "*Program to run after adding a cert to a directory .54Run with one argument, the directory name."55 :group 'ssl56 :type 'string)5758(defcustom ssl-view-certificate-program-name "x509"59 "*The program to run to provide a human-readable view of a certificate."60 :group 'ssl61 :type 'string)6263(defcustom ssl-view-certificate-program-arguments '("-text" "-inform" "DER")64 "*Arguments that should be passed to the certificate viewing program.65The certificate is piped to it.66Maybe a way of passing a file should be implemented"67 :group 'ssl68 :type '(repeat string))6970(defcustom ssl-certificate-directory-style 'ssleay71 "*Style of cert database to use, the only valid value right now is `ssleay'.72This means a directory of pem encoded certificates with hash symlinks."73 :group 'ssl74 :type '(choice (const :tag "SSLeay" :value ssleay)75 (const :tag "OpenSSL" :value openssl)))7677(defcustom ssl-certificate-verification-policy 078 "*How far up the certificate chain we should verify."79 :group 'ssl80 :type '(choice (const :tag "No verification" :value 0)81 (const :tag "Verification required" :value 1)82 (const :tag "Reject connection if verification fails" :value 3)83 (const :tag "SSL_VERIFY_CLIENT_ONCE" :value 5)))8485(defcustom ssl-program-name "openssl"86 "*The program to run in a subprocess to open an SSL connection."87 :group 'ssl88 :type 'string)8990(defcustom ssl-program-arguments91 '("s_client"92 "-quiet"93 "-host" host94 "-port" service95 "-verify" (int-to-string ssl-certificate-verification-policy)96 "-CApath" ssl-certificate-directory97 )98 "*Arguments that should be passed to the program `ssl-program-name'.99This should be used if your SSL program needs command line switches to100specify any behaviour (certificate file locations, etc).101The special symbols 'host and 'port may be used in the list of arguments102and will be replaced with the hostname and service/port that will be connected103to."104 :group 'ssl105 :type 'list)106107(defcustom ssl-view-certificate-program-name ssl-program-name108 "*The program to run to provide a human-readable view of a certificate."109 :group 'ssl110 :type 'string)111112(defcustom ssl-view-certificate-program-arguments113 '("x509" "-text" "-inform" "DER")114 "*Arguments that should be passed to the certificate viewing program.115The certificate is piped to it.116Maybe a way of passing a file should be implemented."117 :group 'ssl118 :type 'list)119120(defun ssl-certificate-information (der)121 "Return an assoc list of information about a certificate in DER format."122 (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n"123 (base64-encode-string der)124 "\n-----END CERTIFICATE-----\n"))125 (exit-code 0))126 (save-excursion127 (set-buffer (get-buffer-create " *openssl*"))128 (erase-buffer)129 (insert certificate)130 (setq exit-code131 (condition-case ()132 (call-process-region (point-min) (point-max)133 ssl-program-name134 t (list (current-buffer) nil) t135 "x509"136 "-subject" ; Print the subject DN137 "-issuer" ; Print the issuer DN138 "-dates" ; Both before and after dates139 "-serial" ; print out serial number140 "-noout" ; Don't spit out the certificate141 )142 (error -1)))143 (if (/= exit-code 0)144 nil145 (let ((vals nil))146 (goto-char (point-min))147 (while (re-search-forward "^\\([^=\n\r]+\\)\\s *=\\s *\\(.*\\)" nil t)148 (push (cons (match-string 1) (match-string 2)) vals))149 vals)))))150 151(defun ssl-accept-ca-certificate ()152 "Ask if the user is willing to accept a new CA certificate.153The buffer name should be the intended name of the certificate, and154the buffer should probably be in DER encoding"155 ;; TODO, check if it is really new or if we already know it156 (let* ((process-connection-type nil)157 (tmpbuf (generate-new-buffer "X509 CA Certificate Information"))158 (response (save-excursion159 (and (eq 0160 (apply 'call-process-region161 (point-min) (point-max)162 ssl-view-certificate-program-name163 nil tmpbuf t164 ssl-view-certificate-program-arguments))165 (switch-to-buffer tmpbuf)166 (goto-char (point-min))167 (or (recenter) t)168 (yes-or-no-p169 "Accept this CA to vouch for secure server identities? ")170 (kill-buffer tmpbuf)))))171 (if (not response)172 nil173 (if (not (file-directory-p ssl-certificate-directory))174 (make-directory ssl-certificate-directory))175 (case ssl-certificate-directory-style176 (ssleay177 (base64-encode-region (point-min) (point-max))178 (goto-char (point-min))179 (insert "-----BEGIN CERTIFICATE-----\n")180 (goto-char (point-max))181 (insert "-----END CERTIFICATE-----\n")182 (let ((f (expand-file-name183 (concat (file-name-sans-extension (buffer-name)) ".pem")184 ssl-certificate-directory)))185 (write-file f)186 (call-process ssl-rehash-program-name187 nil nil nil188 (expand-file-name ssl-certificate-directory))))))))189190(defvar ssl-exec-wrapper nil)191192(defun ssl-get-command ()193 (if (memq system-type '(ms-dos ms-windows axp-vms vax-vms))194 ;; Nothing to do on DOS, Windows, or VMS!195 (cons ssl-program-name ssl-program-arguments)196 (if (not ssl-exec-wrapper)197 (let ((script198 (expand-file-name "exec_ssl_quietly" url-configuration-directory)))199 (if (not (file-executable-p script))200 ;; Need to create our handy-dandy utility script to shut OpenSSL201 ;; up completely.202 (progn203 (write-region "#!/bin/sh\n\nexec \"$@\" 2> /dev/null\n" nil204 script nil 5)205 (set-file-modes script 493))) ; (rwxr-xr-x)206 (setq ssl-exec-wrapper script)))207 (cons ssl-exec-wrapper (cons ssl-program-name ssl-program-arguments))))208209(defun open-ssl-stream (name buffer host service)210 "Open a SSL connection for a service to a host.211Returns a subprocess-object to represent the connection.212Input and output work as for subprocesses; `delete-process' closes it.213Args are NAME BUFFER HOST SERVICE.214NAME is name for process. It is modified if necessary to make it unique.215BUFFER is the buffer (or buffer name) to associate with the process.216Process output goes at end of that buffer, unless you specify217an output stream or filter function to handle the output.218BUFFER may be also nil, meaning that this process is not associated219with any buffer.220Third arg is name of the host to connect to, or its IP address.221Fourth arg SERVICE is name of the service desired, or an integer222specifying a port number to connect to."223 (if (integerp service) (setq service (int-to-string service)))224 (let* ((process-connection-type nil)225 (port service)226 (proc (eval `(start-process name buffer ,@(ssl-get-command)))))227 (process-kill-without-query proc)228 proc))229230(provide 'ssl)231232;; arch-tag: 659fae92-1c67-4055-939f-32153c2f5114233</PRE>234235