Function: network-stream-open-starttls

network-stream-open-starttls is a byte-compiled function defined in network-stream.el.gz.

Signature

(network-stream-open-starttls NAME BUFFER HOST SERVICE PARAMETERS)

Source Code

;; Defined in /usr/src/emacs/lisp/net/network-stream.el.gz
(defun network-stream-open-starttls (name buffer host service parameters)
  (let* ((start (with-current-buffer buffer (point)))
	 (require-tls    (eq (plist-get parameters :type) 'starttls))
	 (starttls-function  (plist-get parameters :starttls-function))
	 (success-string     (plist-get parameters :success))
	 (capability-command (plist-get parameters :capability-command))
	 (eoc                (plist-get parameters :end-of-command))
	 (eo-capa            (or (plist-get parameters :end-of-capability)
				 eoc))
	 ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
	 (stream (make-network-process :name name :buffer buffer
				       :host (puny-encode-domain host)
                                       :service service
                                       :coding (plist-get parameters :coding)))
	 (greeting (and (not (plist-get parameters :nogreeting))
			(network-stream-get-response stream start eoc)))
	 (capabilities
          (network-stream-command
           stream
           (network-stream--capability-command capability-command greeting)
           eo-capa))
	 (resulting-type 'plain)
	 starttls-available starttls-command error)

    ;; First check whether the server supports STARTTLS at all.
    (when (and capabilities success-string starttls-function)
      (setq starttls-command
	    (funcall starttls-function capabilities)))
    ;; If we have built-in STARTTLS support, try to upgrade the
    ;; connection.
    (when (and starttls-command
	       (setq starttls-available
		     (or (gnutls-available-p)
			 (and (or require-tls
				  (plist-get parameters :use-starttls-if-possible))
			      (require 'starttls)
                              (starttls-available-p))))
	       (not (eq (plist-get parameters :type) 'plain)))
      ;; If using external STARTTLS, drop this connection and start
      ;; anew with `starttls-open-stream'.
      (unless (gnutls-available-p)
	(delete-process stream)
	(setq start (with-current-buffer buffer (point-max)))
	(let* ((starttls-extra-arguments
		(if (or require-tls
			(member "--insecure" starttls-extra-arguments))
		    starttls-extra-arguments
		  ;; For opportunistic TLS upgrades, we don't really
		  ;; care about the identity of the peer.
		  (cons "--insecure" starttls-extra-arguments)))
	       (starttls-extra-args starttls-extra-args)
	       (cert (network-stream-certificate host service parameters)))
	  ;; There are client certificates requested, so add them to
	  ;; the command line.
	  (when cert
	    (setq starttls-extra-arguments
		  (nconc (list "--x509keyfile" (expand-file-name (nth 0 cert))
			       "--x509certfile" (expand-file-name (nth 1 cert)))
			 starttls-extra-arguments)
		  starttls-extra-args
		  (nconc (list "--key-file" (expand-file-name (nth 0 cert))
			       "--cert-file" (expand-file-name (nth 1 cert)))
			 starttls-extra-args)))
	  (setq stream (starttls-open-stream name buffer host service)))
	(network-stream-get-response stream start eoc)
	;; Requery capabilities for protocols that require it; i.e.,
	;; EHLO for SMTP.
	(when (plist-get parameters :always-query-capabilities)
	  (network-stream-command
           stream
           (network-stream--capability-command capability-command greeting)
           eo-capa)))
      (when (let ((response
		   (network-stream-command stream starttls-command eoc)))
	      (and response (string-match success-string response)))
	;; The server said it was OK to begin STARTTLS negotiations.
	(if (gnutls-available-p)
	    (let ((cert (network-stream-certificate host service parameters)))
	      (condition-case nil
		  (gnutls-negotiate :process stream
                                    :hostname (puny-encode-domain host)
				    :keylist (and cert (list cert)))
		;; If we get a gnutls-specific error (for instance if
		;; the certificate the server gives us is completely
		;; syntactically invalid), then close the connection
		;; and possibly (further down) try to create a
		;; non-encrypted connection.
		(gnutls-error
		 (delete-process stream))))
	  (unless (starttls-negotiate stream)
	    (delete-process stream)))
	(if (memq (process-status stream) '(open run))
	    (setq resulting-type 'tls)
	  ;; We didn't successfully negotiate STARTTLS; if TLS
	  ;; isn't demanded, reopen an unencrypted connection.
	  (unless require-tls
	    (setq stream
		  (make-network-process :name name :buffer buffer
					:host (puny-encode-domain host)
                                        :service service
                                        :coding (plist-get parameters :coding)))
	    (network-stream-get-response stream start eoc)))
        (unless (process-live-p stream)
          (error "Unable to negotiate a TLS connection with %s/%s"
                 host service))
	;; Re-get the capabilities, which may have now changed.
	(setq capabilities
	      (network-stream-command
               stream
               (network-stream--capability-command capability-command greeting)
               eo-capa))))

    ;; If TLS is mandatory, close the connection if it's unencrypted.
    (when (and require-tls
	       ;; ... but Emacs wasn't able to -- either no built-in
	       ;; support, or no gnutls-cli installed.
	       (eq resulting-type 'plain))
      (setq error
	    (if (or (null starttls-command)
		    starttls-available)
		"Server does not support TLS"
	      ;; See `starttls-available-p'.  If this predicate
	      ;; changes to allow running under Windows, the error
	      ;; message below should be amended.
	      (if (or (memq system-type '(windows-nt ms-dos))
                      (not (featurep 'starttls)))
		  (concat "Emacs does not support TLS")
		(concat "Emacs does not support TLS, and no external `"
			(if starttls-use-gnutls
			    starttls-gnutls-program
			  starttls-program)
			"' program was found"))))
      (delete-process stream)
      (setq stream nil))
    ;; Check certificate validity etc.
    (when (gnutls-available-p)
      (setq stream (nsm-verify-connection
		    stream host service
		    (eq resulting-type 'tls)
		    (plist-get parameters :warn-unless-encrypted))))
    ;; Return value:
    (list stream greeting capabilities resulting-type error)))