[SCM] emacs-jabber branch, master, updated. f54c1b54b308f38caac66ae567e5f64f6adc631c

[Magnus H. <leg...@us...>]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "emacs-jabber".

The branch, master has been updated
       via  f54c1b54b308f38caac66ae567e5f64f6adc631c (commit)
      from  c3c8963e895a5aa7cec57d6cb5c7872a7325f361 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f54c1b54b308f38caac66ae567e5f64f6adc631c
Author: Magnus Henoch <leg...@us...>
Date:   Tue May 15 22:39:43 2012 +0100

    Support native GnuTLS for STARTTLS
    
    Emacs 24 supports linking to the GnuTLS library.  Let's use it when
    available.
    
    Also add a customisable variable for ignoring invalid certificates.
    We should now be validating certificates against the XMPP server name,
    not the hostname from DNS SRV, so there should be less need for this
    now, but there's always the occasional basement server with a
    self-signed certificate...

diff --git a/jabber-conn.el b/jabber-conn.el
index 80b1cca..531d3a0 100644
--- a/jabber-conn.el
+++ b/jabber-conn.el
@@ -27,6 +27,9 @@
 
 (eval-when-compile (require 'cl))
 
+;; Emacs 24 can be linked with GnuTLS
+(ignore-errors (require 'gnutls))
+
 ;; Try two different TLS/SSL libraries, but don't fail if none available.
 (or (ignore-errors (require 'tls))
     (ignore-errors (require 'ssl)))
@@ -45,11 +48,13 @@
 
 (defun jabber-have-starttls ()
   "Return true if we can use STARTTLS."
-  (and (featurep 'starttls)
-       (or (and (bound-and-true-p starttls-gnutls-program)
-		(executable-find starttls-gnutls-program))
-	   (and (bound-and-true-p starttls-program)
-		(executable-find starttls-program)))))
+  (or (and (fboundp 'gnutls-available-p)
+	   (gnutls-available-p))
+      (and (featurep 'starttls)
+	   (or (and (bound-and-true-p starttls-gnutls-program)
+		    (executable-find starttls-gnutls-program))
+	       (and (bound-and-true-p starttls-program)
+		    (executable-find starttls-program))))))
 
 (defconst jabber-default-connection-type 
   (cond
@@ -72,6 +77,16 @@ nil means prefer gnutls but fall back to openssl.
 		 (const :tag "Use openssl" openssl))
   :group 'jabber-conn)
 
+(defcustom jabber-invalid-certificate-servers ()
+  "Jabber servers for which we accept invalid TLS certificates.
+This is a list of server names, each matching the hostname part
+of your JID.
+
+This option has effect only when using native GnuTLS in Emacs 24
+or later."
+  :type '(repeat string)
+  :group 'jabber-conn)
+
 (defvar jabber-connect-methods
   '((network jabber-network-connect jabber-network-send)
     (starttls jabber-starttls-connect jabber-ssl-send)
@@ -191,9 +206,19 @@ connection succeeds.  Send a message :connection-failed if
 connection fails."
   (let ((coding-system-for-read 'utf-8)
 	(coding-system-for-write 'utf-8)
-	(targets (jabber-srv-targets server network-server port)))
-    (unless (fboundp 'starttls-open-stream)
-      (error "starttls.el not available"))
+	(targets (jabber-srv-targets server network-server port))
+	(connect-function
+	 (cond
+	  ((and (fboundp 'gnutls-available-p)
+		(gnutls-available-p))
+	   (lambda (buffer host port)
+	     (open-network-stream "jabber" buffer host port)))
+	  ((fboundp 'starttls-open-stream)
+	   (lambda (buffer host port)
+	     (starttls-open-stream "jabber" buffer host port)))
+	  (t
+	   (error "Neither native GnuTLS nor starttls.el available")))))
+    
     (catch 'connected
       (dolist (target targets)
 	(condition-case e
@@ -201,11 +226,10 @@ connection fails."
 		  connection)
 	      (unwind-protect
 		  (setq connection
-			(starttls-open-stream
-			 "jabber"
-			 process-buffer
-			 (car target)
-			 (cdr target)))
+			(funcall connect-function
+				 process-buffer
+				 (car target)
+				 (cdr target)))
 		(unless (or connection jabber-debug-keep-process-buffers)
 		  (kill-buffer process-buffer)))
 	      (when connection
@@ -226,7 +250,22 @@ connection fails."
 Return non-nil on success, nil on failure."
   (cond
    ((eq (car xml-data) 'proceed)
-    (starttls-negotiate (plist-get (fsm-get-state-data fsm) :connection)))
+    (let* ((state-data (fsm-get-state-data fsm))
+	   (connection (plist-get state-data :connection)))
+      ;; Did we use open-network-stream or starttls-open-stream?  We
+      ;; can tell by process-type.
+      (case (process-type connection)
+	(network
+	 (let* ((hostname (plist-get state-data :server))
+		(verifyp (not (member hostname jabber-invalid-certificate-servers))))
+	   (gnutls-negotiate
+	    :process connection
+	    ;; This is the hostname that the certificate should be valid for:
+	    :hostname hostname
+	    :verify-hostname-error verifyp
+	    :verify-error verifyp)))
+	(real
+	 (starttls-negotiate connection)))))
    ((eq (car xml-data) 'failure)
     nil)))
 

-----------------------------------------------------------------------

Summary of changes:
 jabber-conn.el |   67 ++++++++++++++++++++++++++++++++++++++++++++-----------
 1 files changed, 53 insertions(+), 14 deletions(-)


hooks/post-receive
-- 
emacs-jabber