jabber-sasl.el

   1 ;; jabber-sasl.el - SASL authentication
   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)
  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   ;; Find a suitable common mechanism.
  39   (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms)))
  40          (mechanisms (mapcar
  41                       (lambda (tag)
  42                         (car (jabber-xml-node-children tag)))
  43                       (jabber-xml-get-children mechanism-elements 'mechanism)))
  44          (mechanism
  45           (if (and (member "ANONYMOUS" mechanisms)
  46                    (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? ")))
  47               (sasl-find-mechanism '("ANONYMOUS"))
  48             (sasl-find-mechanism mechanisms))))
  49
  50     ;; No suitable mechanism?
  51     (if (null mechanism)
  52         ;; Maybe we can use legacy authentication
  53         (let ((iq-auth (find "http://jabber.org/features/iq-auth"
  54                           (jabber-xml-get-children stream-features 'auth)
  55                           :key #'jabber-xml-get-xmlns
  56                           :test #'string=))
  57               ;; Or maybe we have to use STARTTLS, but can't
  58               (starttls (find "urn:ietf:params:xml:ns:xmpp-tls"
  59                               (jabber-xml-get-children stream-features 'starttls)
  60                               :key #'jabber-xml-get-xmlns
  61                               :test #'string=)))
  62           (cond
  63            (iq-auth
  64             (fsm-send jc :use-legacy-auth-instead))
  65            (starttls
  66             (message "STARTTLS encryption required, but disabled/non-functional at our end")
  67             (fsm-send jc :authentication-failure))
  68            (t
  69             (message "Authentication failure: no suitable SASL mechanism found")
  70             (fsm-send jc :authentication-failure))))
  71
  72       ;; Watch for plaintext logins over unencrypted connections
  73       (if (and (not (plist-get (fsm-get-state-data jc) :encrypted))
  74                (member (sasl-mechanism-name mechanism)
  75                        '("PLAIN" "LOGIN"))
  76                (not (yes-or-no-p "Jabber server only allows cleartext password transmission!  Continue? ")))
  77           (fsm-send jc :authentication-failure)
  78
  79         ;; Start authentication.
  80         (let* (passphrase
  81                (client (sasl-make-client mechanism
  82                                          (plist-get (fsm-get-state-data jc) :username)
  83                                          "xmpp"
  84                                          (plist-get (fsm-get-state-data jc) :server)))
  85                (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
  86                                       jc
  87                                       (lambda (p) (setq passphrase (copy-sequence p)) p)))
  88                (step (sasl-next-step client nil)))
  89           (jabber-send-sexp
  90            jc
  91            `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")
  92                    (mechanism . ,(sasl-mechanism-name mechanism)))
  93                   ,(when (sasl-step-data step)
  94                      (base64-encode-string (sasl-step-data step) t))))
  95           (list client step passphrase))))))
  96
  97 (defun jabber-sasl-read-passphrase-closure (jc remember)
  98   "Return a lambda function suitable for `sasl-read-passphrase' for JC.
  99 Call REMEMBER with the password.  REMEMBER is expected to return it as well."
 100   (lexical-let ((password (plist-get (fsm-get-state-data jc) :password))
 101                 (bare-jid (jabber-connection-bare-jid jc))
 102                 (remember remember))
 103     (if password
 104         (lambda (prompt) (funcall remember (copy-sequence password)))
 105       (lambda (prompt) (funcall remember (jabber-read-password bare-jid))))))
 106
 107 (defun jabber-sasl-process-input (jc xml-data sasl-data)
 108   (let* ((client (first sasl-data))
 109          (step (second sasl-data))
 110          (passphrase (third sasl-data))
 111          (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
 112                                 jc
 113                                 (lambda (p) (setq passphrase (copy-sequence p)) p))))
 114     (cond
 115      ((eq (car xml-data) 'challenge)
 116       (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
 117       (setq step (sasl-next-step client step))
 118       (jabber-send-sexp
 119        jc
 120        `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
 121                   ,(when (sasl-step-data step)
 122                      (base64-encode-string (sasl-step-data step) t)))))
 123
 124      ((eq (car xml-data) 'failure)
 125       (message "SASL authentication failure: %s"
 126                (jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
 127       (fsm-send jc :authentication-failure))
 128
 129      ((eq (car xml-data) 'success)
 130       (message "Authentication succeeded")
 131       (fsm-send jc (cons :authentication-success passphrase))))
 132     (list client step passphrase)))
 133
 134 (provide 'jabber-sasl)
 135 ;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0