]>
Commit | Line | Data |
---|---|---|
1 | ;; jabber-logon.el - logon functions -*- lexical-binding: t; -*- | |
2 | ||
3 | ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu | |
4 | ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net | |
5 | ||
6 | ;; This file is a part of jabber.el. | |
7 | ||
8 | ;; This program is free software; you can redistribute it and/or modify | |
9 | ;; it under the terms of the GNU General Public License as published by | |
10 | ;; the Free Software Foundation; either version 2 of the License, or | |
11 | ;; (at your option) any later version. | |
12 | ||
13 | ;; This program is distributed in the hope that it will be useful, | |
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;; GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public License | |
19 | ;; along with this program; if not, write to the Free Software | |
20 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
21 | ||
22 | (require 'jabber-xml) | |
23 | (require 'jabber-util) | |
24 | ;; In Emacs 24, sha1 is built in, so this require is only needed for | |
25 | ;; earlier versions. It's supposed to be a noop in Emacs 24, but | |
26 | ;; sometimes, for some people, it isn't, and fails with | |
27 | ;; (file-error "Cannot open load file" "sha1"). | |
28 | (unless (fboundp 'sha1) | |
29 | (require 'sha1)) | |
30 | ||
31 | (defun jabber-get-auth (jc to session-id) | |
32 | "Send IQ get request in namespace \"jabber:iq:auth\". | |
33 | JC is the Jabber connection." | |
34 | (jabber-send-iq jc to | |
35 | "get" | |
36 | `(query ((xmlns . "jabber:iq:auth")) | |
37 | (username () ,(plist-get (fsm-get-state-data jc) :username))) | |
38 | #'jabber-do-logon session-id | |
39 | #'jabber-report-success "Impossible error - auth field request")) | |
40 | ||
41 | (defun jabber-do-logon (jc xml-data session-id) | |
42 | "Send username and password in logon attempt. | |
43 | ||
44 | JC is the Jabber connection. | |
45 | XML-DATA is the parsed tree data from the stream (stanzas) | |
46 | obtained from `xml-parse-region'." | |
47 | (let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest)) | |
48 | (passwd (when | |
49 | (or digest-allowed | |
50 | (plist-get (fsm-get-state-data jc) :encrypted) | |
51 | (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? ")) | |
52 | (or (plist-get (fsm-get-state-data jc) :password) | |
53 | (jabber-read-password (jabber-connection-bare-jid jc))))) | |
54 | auth) | |
55 | (if (null passwd) | |
56 | (fsm-send jc :authentication-failure) | |
57 | (if digest-allowed | |
58 | (setq auth `(digest () ,(sha1 (concat session-id passwd)))) | |
59 | (setq auth `(password () ,passwd))) | |
60 | ;; For legacy authentication we must specify a resource. | |
61 | (unless (plist-get (fsm-get-state-data jc) :resource) | |
62 | ;; Yes, this is ugly. Where is my encapsulation? | |
63 | (plist-put (fsm-get-state-data jc) :resource "emacs-jabber")) | |
64 | (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server) | |
65 | "set" | |
66 | `(query ((xmlns . "jabber:iq:auth")) | |
67 | (username () ,(plist-get (fsm-get-state-data jc) :username)) | |
68 | ,auth | |
69 | (resource () ,(plist-get (fsm-get-state-data jc) :resource))) | |
70 | #'jabber-process-logon passwd | |
71 | #'jabber-process-logon nil)))) | |
72 | ||
73 | (defun jabber-process-logon (jc xml-data closure-data) | |
74 | "Receive login success or failure, and request roster. | |
75 | CLOSURE-DATA should be the password on success and nil on failure. | |
76 | ||
77 | JC is the Jabber connection. | |
78 | XML-DATA is the parsed tree data from the stream (stanzas) | |
79 | obtained from `xml-parse-region'." | |
80 | (if closure-data | |
81 | ;; Logon success | |
82 | (fsm-send jc (cons :authentication-success closure-data)) | |
83 | ||
84 | ;; Logon failure | |
85 | (jabber-report-success jc xml-data "Logon") | |
86 | (fsm-send jc :authentication-failure))) | |
87 | ||
88 | (provide 'jabber-logon) | |
89 | ||
90 | ;;; arch-tag: f24ebe5e-3420-44bb-af81-d4de21f378b0 |