djavu-asus/elpa/jabber-20230715.456/jabber-conn.el

   1 ;; jabber-conn.el - Network transport functions  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni
   4 ;; mostly inspired by Gnus.
   5
   6 ;; Copyright (C) 2005 - Carl Henrik Lunde - chlunde+jabber+@ping.uio.no
   7 ;; (starttls)
   8
   9 ;; This file is a part of jabber.el.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  24
  25 ;; A collection of functions, that hide the details of transmitting to
  26 ;; and from a Jabber Server. Mostly inspired by Gnus.
  27
  28 (eval-when-compile (require 'cl-lib))
  29
  30 ;; Emacs 24 can be linked with GnuTLS
  31 (ignore-errors (require 'gnutls))
  32
  33 ;; Try two different TLS/SSL libraries, but don't fail if none available.
  34 (or (ignore-errors (require 'tls))
  35     (ignore-errors (require 'ssl)))
  36
  37 (ignore-errors (require 'starttls))
  38
  39 (require 'srv)
  40
  41 (defgroup jabber-conn nil "Jabber Connection Settings."
  42   :group 'jabber)
  43
  44 (defun jabber-have-starttls ()
  45   "Return non-nil if we can use STARTTLS."
  46   (or (and (fboundp 'gnutls-available-p)
  47            (gnutls-available-p))
  48       (and (featurep 'starttls)
  49            (or (and (bound-and-true-p starttls-gnutls-program)
  50                     (executable-find starttls-gnutls-program))
  51                (and (bound-and-true-p starttls-program)
  52                     (executable-find starttls-program))))))
  53
  54 (defconst jabber-default-connection-type
  55   (cond
  56    ;; Use STARTTLS if we can...
  57    ((jabber-have-starttls)
  58     'starttls)
  59    ;; ...else default to unencrypted connection.
  60    (t
  61     'network))
  62   "Default connection type.
  63 See `jabber-connect-methods'.")
  64
  65 (defcustom jabber-connection-ssl-program nil
  66   "Program used for SSL/TLS connections.
  67 nil means prefer gnutls but fall back to openssl.
  68 'gnutls' means use gnutls (through `open-tls-stream').
  69 'openssl means use openssl (through `open-ssl-stream')."
  70   :type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil)
  71                  (const :tag "Use gnutls" gnutls)
  72                  (const :tag "Use openssl" openssl))
  73   :group 'jabber-conn)
  74
  75 (defcustom jabber-invalid-certificate-servers ()
  76   "Jabber servers for which we accept invalid TLS certificates.
  77 This is a list of server names, each matching the hostname part
  78 of your JID.
  79
  80 This option has effect only when using native GnuTLS in Emacs 24
  81 or later."
  82   :type '(repeat string)
  83   :group 'jabber-conn)
  84
  85 (defvar jabber-connect-methods
  86   `((network jabber-network-connect jabber-network-send)
  87     (starttls
  88      ,(if (and (fboundp 'gnutls-available-p)
  89                (gnutls-available-p))
  90           ;; With "native" TLS, we can use a normal connection.
  91           'jabber-network-connect
  92         'jabber-starttls-connect)
  93      jabber-network-send)
  94     (ssl jabber-ssl-connect jabber-ssl-send)
  95     (virtual jabber-virtual-connect jabber-virtual-send))
  96   "Alist of connection methods and functions.
  97 First item is the symbol naming the method.
  98 Second item is the connect function.
  99 Third item is the send function.")
 100
 101 (defun jabber-get-connect-function (type)
 102   "Get the connect function associated with TYPE.
 103 TYPE is a symbol; see `jabber-connection-type'."
 104   (let ((entry (assq type jabber-connect-methods)))
 105     (nth 1 entry)))
 106
 107 (defun jabber-get-send-function (type)
 108   "Get the send function associated with TYPE.
 109 TYPE is a symbol; see `jabber-connection-type'."
 110   (let ((entry (assq type jabber-connect-methods)))
 111     (nth 2 entry)))
 112
 113 (defun jabber-srv-targets (server network-server port)
 114   "Find host and port to connect to.
 115 If NETWORK-SERVER and/or PORT are specified, use them.
 116 If we can't find SRV records, use standard defaults."
 117   ;; If the user has specified a host or a port, obey that.
 118   (if (or network-server port)
 119       (list (cons (or network-server server)
 120                   (or port 5222)))
 121     (or (condition-case nil
 122             (srv-lookup (concat "_xmpp-client._tcp." server))
 123           (error nil))
 124         (list (cons server 5222)))))
 125
 126 ;; Plain TCP/IP connection
 127 (defun jabber-network-connect (fsm server network-server port)
 128   "Connect to a Jabber server with a plain network connection.
 129 Send a message of the form (:connected CONNECTION) to FSM if
 130 connection succeeds.  Send a message (:connection-failed ERRORS) if
 131 connection fails."
 132   (cond
 133    ((featurep 'make-network-process '(:nowait t))
 134     ;; We can connect asynchronously!
 135     (jabber-network-connect-async fsm server network-server port))
 136    (t
 137     ;; Connecting to the server will block Emacs.
 138     (jabber-network-connect-sync fsm server network-server port))))
 139
 140 (defun jabber-network-connect-async (fsm server network-server port)
 141   ;; Get all potential targets...
 142   (let ((targets (jabber-srv-targets server network-server port))
 143                 errors
 144                 (fsm fsm))
 145     ;; ...and connect to them one after another, asynchronously, until
 146     ;; connection succeeds.
 147     (cl-labels
 148         ((connect
 149           (target remaining-targets)
 150           (let ((target target) (remaining-targets remaining-targets))
 151             (cl-labels ((connection-successful
 152                       (c)
 153                       ;; This mustn't be `fsm-send-sync', because the FSM
 154                       ;; needs to change the sentinel, which cannot be done
 155                       ;; from inside the sentinel.
 156                       (fsm-send fsm (list :connected c)))
 157                      (connection-failed
 158                       (c status)
 159                       (when (and (> (length status) 0)
 160                                  (eq (aref status (1- (length status))) ?\n))
 161                         (setq status (substring status 0 -1)))
 162                       (let ((err
 163                              (format "Couldn't connect to %s:%s: %s"
 164                                      (car target) (cdr target) status)))
 165                         (message "%s" err)
 166                         (push err errors))
 167                       (when c (delete-process c))
 168                       (if remaining-targets
 169                           (progn
 170                             (message
 171                              "Connecting to %s:%s..."
 172                              (caar remaining-targets) (cdar remaining-targets))
 173                             (connect (car remaining-targets) (cdr remaining-targets)))
 174                         (fsm-send fsm (list :connection-failed (nreverse errors))))))
 175               (condition-case e
 176                   (make-network-process
 177                    :name "jabber"
 178                    :buffer (generate-new-buffer jabber-process-buffer)
 179                    :host (car target) :service (cdr target)
 180                    :coding 'utf-8
 181                    :nowait t
 182                    :sentinel
 183                    (let ((_target target) (_remaining-targets remaining-targets))
 184                      (lambda (connection status)
 185                        (cond
 186                         ((string-match "^open" status)
 187                          (connection-successful connection))
 188                         ((string-match "^failed" status)
 189                          (connection-failed connection status))
 190                         ((string-match "^deleted" status)
 191                          ;; This happens when we delete a process in the
 192                          ;; "failed" case above.
 193                          nil)
 194                         (t
 195                          (message "Unknown sentinel status `%s'" status))))))
 196                 (file-error
 197                  ;; A file-error has the error message in the third list
 198                  ;; element.
 199                  (connection-failed nil (car (cddr e))))
 200                 (error
 201                  ;; Not sure if we ever get anything but file-errors,
 202                  ;; but let's make sure we report them:
 203                  (connection-failed nil (error-message-string e))))))))
 204       (message "Connecting to %s:%s..." (caar targets) (cdar targets))
 205       (connect (car targets) (cdr targets)))))
 206
 207 (defun jabber-network-connect-sync (fsm server network-server port)
 208   ;; This code will AFAIK only be used on Windows.  Apologies in
 209   ;; advance for any bit rot...
 210   (let ((coding-system-for-read 'utf-8)
 211         (coding-system-for-write 'utf-8)
 212         (targets (jabber-srv-targets server network-server port))
 213         errors)
 214     (catch 'connected
 215       (dolist (target targets)
 216         (condition-case e
 217             (let ((process-buffer (generate-new-buffer jabber-process-buffer))
 218                   connection)
 219               (unwind-protect
 220                   (setq connection (open-network-stream
 221                                     "jabber"
 222                                     process-buffer
 223                                     (car target)
 224                                     (cdr target)))
 225
 226                 (unless (or connection jabber-debug-keep-process-buffers)
 227                   (kill-buffer process-buffer)))
 228
 229               (when connection
 230                 (fsm-send fsm (list :connected connection))
 231                 (throw 'connected connection)))
 232           (file-error
 233            ;; A file-error has the error message in the third list
 234            ;; element.
 235            (let ((err (format "Couldn't connect to %s:%s: %s"
 236                               (car target) (cdr target)
 237                               (car (cddr e)))))
 238              (message "%s" err)
 239              (push err errors)))
 240           (error
 241            ;; Not sure if we ever get anything but file-errors,
 242            ;; but let's make sure we report them:
 243            (let ((err (format "Couldn't connect to %s:%s: %s"
 244                               (car target) (cdr target)
 245                               (error-message-string e))))
 246              (message "%s" err)
 247              (push err errors)))))
 248       (fsm-send fsm (list :connection-failed (nreverse errors))))))
 249
 250 (defun jabber-network-send (connection string)
 251   "Send a string via a plain TCP/IP connection to the Jabber Server."
 252   (process-send-string connection string))
 253
 254 ;; SSL connection, we use openssl's s_client function for encryption
 255 ;; of the link
 256 ;; TODO: make this configurable
 257 (defun jabber-ssl-connect (fsm server network-server port)
 258   "Connect via OpenSSL or GnuTLS to a Jabber Server.
 259 Send a message of the form (:connected CONNECTION) to FSM if
 260 connection succeeds.  Send a message (:connection-failed ERRORS) if
 261 connection fails."
 262   (let ((coding-system-for-read 'utf-8)
 263         (coding-system-for-write 'utf-8)
 264         (connect-function
 265          (cond
 266           ((and (memq jabber-connection-ssl-program '(nil gnutls))
 267                 (fboundp 'open-tls-stream))
 268            'open-tls-stream)
 269           ((and (memq jabber-connection-ssl-program '(nil openssl))
 270                 (fboundp 'open-ssl-stream))
 271            'open-ssl-stream)
 272           (t
 273            (error "Neither TLS nor SSL connect functions available"))))
 274         error-msg)
 275     (let ((process-buffer (generate-new-buffer jabber-process-buffer))
 276           connection)
 277       (setq network-server (or network-server server))
 278       (setq port (or port 5223))
 279       (condition-case e
 280           (setq connection (funcall connect-function
 281                                     "jabber"
 282                                     process-buffer
 283                                     network-server
 284                                     port))
 285         (error
 286          (setq error-msg
 287                (format "Couldn't connect to %s:%d: %s" network-server port
 288                        (error-message-string e)))
 289          (message "%s" error-msg)))
 290       (unless (or connection jabber-debug-keep-process-buffers)
 291         (kill-buffer process-buffer))
 292       (if connection
 293           (fsm-send fsm (list :connected connection))
 294         (fsm-send fsm (list :connection-failed
 295                             (when error-msg (list error-msg))))))))
 296
 297 (defun jabber-ssl-send (connection string)
 298   "Send a string via an SSL-encrypted connection to the Jabber Server."
 299   ;; It seems we need to send a linefeed afterwards.
 300   (process-send-string connection string)
 301   (process-send-string connection "\n"))
 302
 303 (defun jabber-starttls-connect (fsm server network-server port)
 304   "Connect via an external GnuTLS process to a Jabber Server.
 305 Send a message of the form (:connected CONNECTION) to FSM if
 306 connection succeeds.  Send a message (:connection-failed ERRORS) if
 307 connection fails."
 308   (let ((coding-system-for-read 'utf-8)
 309         (coding-system-for-write 'utf-8)
 310         (targets (jabber-srv-targets server network-server port))
 311         errors)
 312     (unless (fboundp 'starttls-open-stream)
 313       (error "The starttls.el library is not available"))
 314     (catch 'connected
 315       (dolist (target targets)
 316         (condition-case e
 317             (let ((process-buffer (generate-new-buffer jabber-process-buffer))
 318                   connection)
 319               (unwind-protect
 320                   (setq connection
 321                         (starttls-open-stream
 322                          "jabber"
 323                          process-buffer
 324                          (car target)
 325                          (cdr target)))
 326                 (unless (or connection jabber-debug-keep-process-buffers)
 327                   (kill-buffer process-buffer)))
 328               (if (null connection)
 329                   ;; It seems we don't actually get an error if we
 330                   ;; can't connect.  Let's try to convey some useful
 331                   ;; information to the user at least.
 332                   (let ((err (format "Couldn't connect to %s:%s"
 333                                      (car target) (cdr target))))
 334                     (message "%s" err)
 335                     (push err errors))
 336                 (fsm-send fsm (list :connected connection))
 337                 (throw 'connected connection)))
 338           (error
 339            (let ((err (format "Couldn't connect to %s: %s" target
 340                               (error-message-string e))))
 341              (message "%s" err)
 342              (push err errors)))))
 343         (fsm-send fsm (list :connection-failed (nreverse errors))))))
 344
 345 (defun jabber-starttls-initiate (fsm)
 346   "Initiate a STARTTLS connection."
 347   (jabber-send-sexp fsm
 348    '(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls")))))
 349
 350 (defun jabber-starttls-process-input (fsm xml-data)
 351   "Process result of starttls request.
 352 On failure, signal error.
 353
 354 XML-DATA is the parsed tree data from the stream (stanzas)
 355 obtained from `xml-parse-region'."
 356   (cond
 357    ((eq (car xml-data) 'proceed)
 358     (let* ((state-data (fsm-get-state-data fsm))
 359            (connection (plist-get state-data :connection)))
 360       ;; Did we use open-network-stream or starttls-open-stream?  We
 361       ;; can tell by process-type.
 362       (cl-case (process-type connection)
 363         (network
 364          (let* ((hostname (plist-get state-data :server))
 365                 (verifyp (not (member hostname jabber-invalid-certificate-servers))))
 366            ;; gnutls-negotiate might signal an error, which is caught
 367            ;; by our caller
 368            (gnutls-negotiate
 369             :process connection
 370             ;; This is the hostname that the certificate should be valid for:
 371             :hostname hostname
 372             :verify-hostname-error verifyp
 373             :verify-error verifyp)))
 374         (real
 375          (or
 376           (starttls-negotiate connection)
 377           (error "Negotiation failure"))))))
 378    ((eq (car xml-data) 'failure)
 379     (error "Command rejected by server"))))
 380
 381 (defvar *jabber-virtual-server-function* nil
 382   "Function to use for sending stanzas on a virtual connection.
 383 The function should accept two arguments, the connection object
 384 and a string that the connection wants to send.")
 385
 386 (defun jabber-virtual-connect (fsm _server _network-server _port)
 387   "Connect to a virtual \"server\".
 388 Use `*jabber-virtual-server-function*' as send function.
 389 FSM is the finite state machine created in jabber.el library."
 390   (unless (functionp *jabber-virtual-server-function*)
 391     (error "No virtual server function specified"))
 392   ;; We pass the fsm itself as "connection object", as that is what a
 393   ;; virtual server needs to send stanzas.
 394   (fsm-send fsm (list :connected fsm)))
 395
 396 (defun jabber-virtual-send (connection string)
 397   (funcall *jabber-virtual-server-function* connection string))
 398
 399 (provide 'jabber-conn)
 400 ;; arch-tag: f95ec240-8cd3-11d9-9dbf-000a95c2fcd0