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

   1 ;; jabber-sasl.el - SASL authentication  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4
   5 ;; This file is a part of jabber.el.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, write to the Free Software
  19 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20
  21 (require 'cl-lib)
  22
  23 ;;; This file uses sasl.el from FLIM or Gnus.  If it can't be found,
  24 ;;; jabber-core.el won't use the SASL functions.
  25 (eval-and-compile
  26   (condition-case nil
  27       (require 'sasl)
  28     (error nil)))
  29
  30 ;;; Alternatives to FLIM would be the command line utility of GNU SASL,
  31 ;;; or anything the Gnus people decide to use.
  32
  33 ;;; See XMPP-CORE and XMPP-IM for details about the protocol.
  34
  35 (require 'jabber-xml)
  36
  37 (defun jabber-sasl-start-auth (jc stream-features)
  38 "Start the SASL authentication mechanism.
  39 JC is The Jabber Connection.
  40 STREAM-FEATURES the XML parsed \"stream features\" answer (it is used
  41 with `jabber-xml-get-chidlren')."
  42   ;; Find a suitable common mechanism.
  43   (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms)))
  44          (mechanisms (mapcar
  45                       (lambda (tag)
  46                         (car (jabber-xml-node-children tag)))
  47                       (jabber-xml-get-children mechanism-elements 'mechanism)))
  48          (mechanism
  49           (if (and (member "ANONYMOUS" mechanisms)
  50                    (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? ")))
  51               (sasl-find-mechanism '("ANONYMOUS"))
  52             (sasl-find-mechanism mechanisms))))
  53
  54     ;; No suitable mechanism?
  55     (if (null mechanism)
  56         ;; Maybe we can use legacy authentication
  57         (let ((iq-auth (cl-find "http://jabber.org/features/iq-auth"
  58                           (jabber-xml-get-children stream-features 'auth)
  59                           :key #'jabber-xml-get-xmlns
  60                           :test #'string=))
  61               ;; Or maybe we have to use STARTTLS, but can't
  62               (starttls (cl-find "urn:ietf:params:xml:ns:xmpp-tls"
  63                               (jabber-xml-get-children stream-features 'starttls)
  64                               :key #'jabber-xml-get-xmlns
  65                               :test #'string=)))
  66           (cond
  67            (iq-auth
  68             (fsm-send jc :use-legacy-auth-instead))
  69            (starttls
  70             (message "STARTTLS encryption required, but disabled/non-functional at our end")
  71             (fsm-send jc :authentication-failure))
  72            (t
  73             (message "Authentication failure: no suitable SASL mechanism found")
  74             (fsm-send jc :authentication-failure))))
  75
  76       ;; Watch for plaintext logins over unencrypted connections
  77       (if (and (not (plist-get (fsm-get-state-data jc) :encrypted))
  78                (member (sasl-mechanism-name mechanism)
  79                        '("PLAIN" "LOGIN"))
  80                (not (yes-or-no-p "Jabber server only allows cleartext password transmission!  Continue? ")))
  81           (fsm-send jc :authentication-failure)
  82
  83         ;; Start authentication.
  84         (let* (passphrase
  85                (client (sasl-make-client mechanism
  86                                          (plist-get (fsm-get-state-data jc) :username)
  87                                          "xmpp"
  88                                          (plist-get (fsm-get-state-data jc) :server)))
  89                (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
  90                                       jc
  91                                       (lambda (p) (setq passphrase (copy-sequence p)) p)))
  92                (step (sasl-next-step client nil)))
  93           (jabber-send-sexp
  94            jc
  95            `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")
  96                    (mechanism . ,(sasl-mechanism-name mechanism)))
  97                   ,(when (sasl-step-data step)
  98                      (base64-encode-string (sasl-step-data step) t))))
  99           (list client step passphrase))))))
 100
 101 (defun jabber-sasl-read-passphrase-closure (jc remember)
 102   "Return a lambda function suitable for `sasl-read-passphrase' for JC.
 103 Call REMEMBER with the password.  REMEMBER is expected to return it as well."
 104   (let ((password (plist-get (fsm-get-state-data jc) :password))
 105                 (bare-jid (jabber-connection-bare-jid jc))
 106                 (remember remember))
 107     (if password
 108         (lambda (_prompt) (funcall remember (copy-sequence password)))
 109       (lambda (_prompt) (funcall remember (jabber-read-password bare-jid))))))
 110
 111 (defun jabber-sasl-process-input (jc xml-data sasl-data)
 112 "SASL protocol input processing.
 113
 114 JC is the Jabber connection.
 115 XML-DATA is the parsed tree data from the stream (stanzas)
 116 obtained from `xml-parse-region'."
 117   (let* ((client (cl-first sasl-data))
 118          (step (cl-second sasl-data))
 119          (passphrase (cl-third sasl-data))
 120          (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
 121                                 jc
 122                                 (lambda (p) (setq passphrase (copy-sequence p)) p))))
 123     (cond
 124      ((eq (car xml-data) 'challenge)
 125       (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
 126       (setq step (sasl-next-step client step))
 127       (jabber-send-sexp
 128        jc
 129        `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
 130                   ,(when (sasl-step-data step)
 131                      (base64-encode-string (sasl-step-data step) t)))))
 132
 133      ((eq (car xml-data) 'failure)
 134       (message "%s: authentication failure: %s"
 135                (jabber-connection-bare-jid jc)
 136                (jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
 137       (fsm-send jc :authentication-failure))
 138
 139      ((eq (car xml-data) 'success)
 140       ;; The server might, depending on the mechanism, send
 141       ;; "additional data" (see RFC 4422) with the <success/> element.
 142       ;; Since some SASL mechanisms perform mutual authentication, we
 143       ;; need to pass this data to sasl.el - we're not necessarily
 144       ;; done just because the server says we're done.
 145       (let* ((data (car (jabber-xml-node-children xml-data)))
 146              (decoded (if data
 147                           (base64-decode-string data)
 148                         "")))
 149         (sasl-step-set-data step decoded)
 150         (condition-case e
 151             (progn
 152               ;; Check that sasl-next-step doesn't signal an error.
 153               ;; TODO: once sasl.el allows it, check that all steps have
 154               ;; been completed.
 155               (sasl-next-step client step)
 156               (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc))
 157               (fsm-send jc (cons :authentication-success passphrase)))
 158           (sasl-error
 159            (message "%s: authentication failure: %s"
 160                     (jabber-connection-bare-jid jc)
 161                     (error-message-string e))
 162            (fsm-send jc :authentication-failure))))))
 163     (list client step passphrase)))
 164
 165 (provide 'jabber-sasl)
 166 ;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0