[Emacs-diffs] /srv/bzr/emacs/trunk r104662: Add support for client certificates for built-in and external STARTTLS.

[Lars Magne Ingebrigtsen]

------------------------------------------------------------
revno: 104662
committer: Lars Magne Ingebrigtsen <address@hidden>
branch nick: trunk
timestamp: Tue 2011-06-21 22:39:08 +0200
message:
  Add support for client certificates for built-in and external STARTTLS.
modified:
  lisp/ChangeLog
  lisp/net/network-stream.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-06-21 19:51:26 +0000
+++ b/lisp/ChangeLog    2011-06-21 20:39:08 +0000
@@ -1,3 +1,11 @@
+2011-06-21  Lars Magne Ingebrigtsen  <address@hidden>
+
+       * net/network-stream.el (network-stream-open-starttls): Provide
+       support for client certificates both for external and built-in
+       STARTTLS.
+       (auth-source): Require.
+       (open-network-stream): Document the :client-certificate keyword.
+
 2011-06-21  Michael Albinus  <address@hidden>
 
        * net/tramp-cache.el (top): Don't load the persistency file when

=== modified file 'lisp/net/network-stream.el'
--- a/lisp/net/network-stream.el        2011-06-15 20:44:45 +0000
+++ b/lisp/net/network-stream.el        2011-06-21 20:39:08 +0000
@@ -44,6 +44,7 @@
 
 (require 'tls)
 (require 'starttls)
+(require 'auth-source)
 
 (declare-function gnutls-negotiate "gnutls" t t) ; defun*
 
@@ -110,10 +111,17 @@
   STARTTLS if the server supports STARTTLS, and nil otherwise.
 
 :always-query-capabilies says whether to query the server for
-capabilities, even if we're doing a `plain' network connection.
+  capabilities, even if we're doing a `plain' network connection.
+
+:client-certificate should either be a list where the first
+  element is the certificate key file name, and the second
+  element is the certificate file name itself, or `t', which
+  means that `auth-source' will be queried for the key and the
+  certificate.  This parameter will only be used when doing TLS
+  or STARTTLS connections.
 
 :nowait is a boolean that says the connection should be made
-asynchronously, if possible."
+  asynchronously, if possible."
   (unless (featurep 'make-network-process)
     (error "Emacs was compiled without networking support"))
   (let ((type (plist-get parameters :type))
@@ -152,6 +160,22 @@
                  :type         (nth 3 result))
          (car result))))))
 
+(defun network-stream-certificate (host service parameters)
+  (let ((spec (plist-get :client-certificate parameters)))
+    (cond
+     ((listp spec)
+      ;; Either nil or a list with a key/certificate pair.
+      spec)
+     ((eq spec t)
+      (let* ((auth-info
+             (car (auth-source-search :max 1
+                                      :host host
+                                      :port service)))
+            (key (plist-get auth-info :cert-key))
+            (cert (plist-get auth-info :cert-cert)))
+       (and key cert
+            (list key cert)))))))
+
 ;;;###autoload
 (defalias 'open-protocol-stream 'open-network-stream)
 
@@ -201,14 +225,24 @@
                    starttls-extra-arguments
                  ;; For opportunistic TLS upgrades, we don't really
                  ;; care about the identity of the peer.
-                 (cons "--insecure" starttls-extra-arguments))))
+                 (cons "--insecure" starttls-extra-arguments)))
+              (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" (nth 0 cert)
+                              "--x509certfile" (nth 1 cert))
+                        starttls-extra-arguments)))
          (setq stream (starttls-open-stream name buffer host service)))
        (network-stream-get-response stream start eoc))
       (when (string-match success-string
                          (network-stream-command stream starttls-command eoc))
        ;; The server said it was OK to begin STARTTLS negotiations.
        (if (fboundp 'open-gnutls-stream)
-           (gnutls-negotiate :process stream :hostname host)
+           (let ((cert (network-stream-certificate host service parameters)))
+             (gnutls-negotiate :process stream :hostname host
+                               :keylist (and cert (list cert))))
          (unless (starttls-negotiate stream)
            (delete-process stream)))
        (if (memq (process-status stream) '(open run))