(defgroup starttls nil
"Support for `Transport Layer Security' protocol."
:version "21.1"
:group 'mail)
(defcustom starttls-gnutls-program "gnutls-cli"
"Name of GNUTLS command line tool.
This program is used when GNUTLS is used, i.e. when
`starttls-use-gnutls' is non-nil."
:version "22.1"
:type 'string
:group 'starttls)
(defcustom starttls-program "starttls"
"The program to run in a subprocess to open an TLSv1 connection.
This program is used when the `starttls' command is used,
i.e. when `starttls-use-gnutls' is nil."
:type 'string
:group 'starttls)
(defcustom starttls-use-gnutls (not (executable-find starttls-program))
"*Whether to use GNUTLS instead of the `starttls' command."
:version "22.1"
:type 'boolean
:group 'starttls)
(defcustom starttls-extra-args nil
"Extra arguments to `starttls-program'.
These apply when the `starttls' command is used, i.e. when
`starttls-use-gnutls' is nil."
:type '(repeat string)
:group 'starttls)
(defcustom starttls-extra-arguments nil
"Extra arguments to `starttls-program'.
These apply when GNUTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
For example, non-TLS compliant servers may require
'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
find out which parameters are available."
:version "22.1"
:type '(repeat string)
:group 'starttls)
(defcustom starttls-process-connection-type nil
"*Value for `process-connection-type' to use when starting STARTTLS process."
:version "22.1"
:type 'boolean
:group 'starttls)
(defcustom starttls-connect "- Simple Client Mode:\n\n"
"*Regular expression indicating successful connection.
The default is what GNUTLS's \"gnutls-cli\" outputs."
:version "22.1"
:type 'regexp
:group 'starttls)
(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
"*Regular expression indicating failed TLS handshake.
The default is what GNUTLS's \"gnutls-cli\" outputs."
:version "22.1"
:type 'regexp
:group 'starttls)
(defcustom starttls-success "- Compression: "
"*Regular expression indicating completed TLS handshakes.
The default is what GNUTLS's \"gnutls-cli\" outputs."
:version "22.1"
:type 'regexp
:group 'starttls)
(defun starttls-negotiate-gnutls (process)
"Negotiate TLS on PROCESS opened by `open-starttls-stream'.
This should typically only be done once. It typically returns a
multi-line informational message with information about the
handshake, or nil on failure."
(let (buffer info old-max done-ok done-bad)
(if (null (setq buffer (process-buffer process)))
(signal-process (process-id process) 'SIGALRM)
(with-current-buffer buffer
(save-excursion
(setq old-max (goto-char (point-max)))
(signal-process (process-id process) 'SIGALRM)
(while (and (processp process)
(eq (process-status process) 'run)
(save-excursion
(goto-char old-max)
(not (or (setq done-ok (re-search-forward
starttls-success nil t))
(setq done-bad (re-search-forward
starttls-failure nil t))))))
(accept-process-output process 1 100)
(sit-for 0.1))
(setq info (buffer-substring-no-properties old-max (point-max)))
(delete-region old-max (point-max))
(if (or (and done-ok (not done-bad))
(and done-ok done-bad (< done-ok done-bad)))
info
(message "STARTTLS negotiation failed: %s" info)
nil))))))
(defun starttls-negotiate (process)
(if starttls-use-gnutls
(starttls-negotiate-gnutls process)
(signal-process (process-id process) 'SIGALRM)))
(eval-and-compile
(if (fboundp 'set-process-query-on-exit-flag)
(defalias 'starttls-set-process-query-on-exit-flag
'set-process-query-on-exit-flag)
(defalias 'starttls-set-process-query-on-exit-flag
'process-kill-without-query)))
(defun starttls-open-stream-gnutls (name buffer host port)
(message "Opening STARTTLS connection to `%s'..." host)
(let* (done
(old-max (with-current-buffer buffer (point-max)))
(process-connection-type starttls-process-connection-type)
(process (apply #'start-process name buffer
starttls-gnutls-program "-s" host
"-p" (if (integerp port)
(int-to-string port)
port)
starttls-extra-arguments)))
(starttls-set-process-query-on-exit-flag process nil)
(while (and (processp process)
(eq (process-status process) 'run)
(save-excursion
(set-buffer buffer)
(goto-char old-max)
(not (setq done (re-search-forward
starttls-connect nil t)))))
(accept-process-output process 0 100)
(sit-for 0.1))
(if done
(with-current-buffer buffer
(delete-region old-max done))
(delete-process process)
(setq process nil))
(message "Opening STARTTLS connection to `%s'...%s"
host (if done "done" "failed"))
process))
(defun starttls-open-stream (name buffer host port)
"Open a TLS connection for a port to a host.
Returns a subprocess object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
Args are NAME BUFFER HOST PORT.
NAME is name for process. It is modified if necessary to make it unique.
BUFFER is the buffer (or `buffer-name') to associate with the process.
Process output goes at end of that buffer, unless you specify
an output stream or filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
with any buffer
Third arg is name of the host to connect to, or its IP address.
Fourth arg PORT is an integer specifying a port to connect to.
If `starttls-use-gnutls' is nil, this may also be a service name, but
GNUTLS requires a port number."
(if starttls-use-gnutls
(starttls-open-stream-gnutls name buffer host port)
(let* ((process-connection-type starttls-process-connection-type)
(process (apply #'start-process
name buffer starttls-program
host (format "%s" port)
starttls-extra-args)))
(starttls-set-process-query-on-exit-flag process nil)
process)))
(provide 'starttls)