[config.git] / djavu-asus / elpa / jabber-20230715.456 / jabber-sasl.el

;; jabber-sasl.el - SASL authentication  -*- lexical-binding: t; -*-

;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu

;; This file is a part of jabber.el.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

(require 'cl-lib)

;;; This file uses sasl.el from FLIM or Gnus.  If it can't be found,
;;; jabber-core.el won't use the SASL functions.
(eval-and-compile
  (condition-case nil
      (require 'sasl)
    (error nil)))

;;; Alternatives to FLIM would be the command line utility of GNU SASL,
;;; or anything the Gnus people decide to use.

;;; See XMPP-CORE and XMPP-IM for details about the protocol.

(require 'jabber-xml)

(defun jabber-sasl-start-auth (jc stream-features)
"Start the SASL authentication mechanism.
JC is The Jabber Connection.
STREAM-FEATURES the XML parsed \"stream features\" answer (it is used
with `jabber-xml-get-chidlren')."
  ;; Find a suitable common mechanism.
  (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms)))
	 (mechanisms (mapcar
		      (lambda (tag)
			(car (jabber-xml-node-children tag)))
		      (jabber-xml-get-children mechanism-elements 'mechanism)))
	 (mechanism
	  (if (and (member "ANONYMOUS" mechanisms)
		   (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? ")))
	      (sasl-find-mechanism '("ANONYMOUS"))
	    (sasl-find-mechanism mechanisms))))

    ;; No suitable mechanism?
    (if (null mechanism)
	;; Maybe we can use legacy authentication
	(let ((iq-auth (cl-find "http://jabber.org/features/iq-auth"
			  (jabber-xml-get-children stream-features 'auth)
			  :key #'jabber-xml-get-xmlns
			  :test #'string=))
	      ;; Or maybe we have to use STARTTLS, but can't
	      (starttls (cl-find "urn:ietf:params:xml:ns:xmpp-tls"
			      (jabber-xml-get-children stream-features 'starttls)
			      :key #'jabber-xml-get-xmlns
			      :test #'string=)))
	  (cond
	   (iq-auth
	    (fsm-send jc :use-legacy-auth-instead))
	   (starttls
	    (message "STARTTLS encryption required, but disabled/non-functional at our end")
	    (fsm-send jc :authentication-failure))
	   (t
	    (message "Authentication failure: no suitable SASL mechanism found")
	    (fsm-send jc :authentication-failure))))

      ;; Watch for plaintext logins over unencrypted connections
      (if (and (not (plist-get (fsm-get-state-data jc) :encrypted))
	       (member (sasl-mechanism-name mechanism)
		       '("PLAIN" "LOGIN"))
	       (not (yes-or-no-p "Jabber server only allows cleartext password transmission!  Continue? ")))
	  (fsm-send jc :authentication-failure)

	;; Start authentication.
	(let* (passphrase
	       (client (sasl-make-client mechanism
					 (plist-get (fsm-get-state-data jc) :username)
					 "xmpp"
					 (plist-get (fsm-get-state-data jc) :server)))
	       (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
				      jc
				      (lambda (p) (setq passphrase (copy-sequence p)) p)))
	       (step (sasl-next-step client nil)))
	  (jabber-send-sexp
	   jc
	   `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")
		   (mechanism . ,(sasl-mechanism-name mechanism)))
		  ,(when (sasl-step-data step)
		     (base64-encode-string (sasl-step-data step) t))))
	  (list client step passphrase))))))

(defun jabber-sasl-read-passphrase-closure (jc remember)
  "Return a lambda function suitable for `sasl-read-passphrase' for JC.
Call REMEMBER with the password.  REMEMBER is expected to return it as well."
  (let ((password (plist-get (fsm-get-state-data jc) :password))
		(bare-jid (jabber-connection-bare-jid jc))
		(remember remember))
    (if password
	(lambda (_prompt) (funcall remember (copy-sequence password)))
      (lambda (_prompt) (funcall remember (jabber-read-password bare-jid))))))

(defun jabber-sasl-process-input (jc xml-data sasl-data)
"SASL protocol input processing.

JC is the Jabber connection.
XML-DATA is the parsed tree data from the stream (stanzas)
obtained from `xml-parse-region'."
  (let* ((client (cl-first sasl-data))
	 (step (cl-second sasl-data))
	 (passphrase (cl-third sasl-data))
	 (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
				jc
				(lambda (p) (setq passphrase (copy-sequence p)) p))))
    (cond
     ((eq (car xml-data) 'challenge)
      (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
      (setq step (sasl-next-step client step))
      (jabber-send-sexp
       jc
       `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
		  ,(when (sasl-step-data step)
		     (base64-encode-string (sasl-step-data step) t)))))

     ((eq (car xml-data) 'failure)
      (message "%s: authentication failure: %s"
	       (jabber-connection-bare-jid jc)
	       (jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
      (fsm-send jc :authentication-failure))

     ((eq (car xml-data) 'success)
      ;; The server might, depending on the mechanism, send
      ;; "additional data" (see RFC 4422) with the <success/> element.
      ;; Since some SASL mechanisms perform mutual authentication, we
      ;; need to pass this data to sasl.el - we're not necessarily
      ;; done just because the server says we're done.
      (let* ((data (car (jabber-xml-node-children xml-data)))
	     (decoded (if data
			  (base64-decode-string data)
			"")))
	(sasl-step-set-data step decoded)
	(condition-case e
	    (progn
	      ;; Check that sasl-next-step doesn't signal an error.
	      ;; TODO: once sasl.el allows it, check that all steps have
	      ;; been completed.
	      (sasl-next-step client step)
	      (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc))
	      (fsm-send jc (cons :authentication-success passphrase)))
	  (sasl-error
	   (message "%s: authentication failure: %s"
		    (jabber-connection-bare-jid jc)
		    (error-message-string e))
	   (fsm-send jc :authentication-failure))))))
    (list client step passphrase)))

(provide 'jabber-sasl)
;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0
Commit	Line	Data
53e6db90 DC	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