1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
;;; Test the client by capturing its input and output into a virtual
;;; jabber server. This is not a test in itself, but a framework for
;;; actual tests.
(require 'jabber)
(require 'cl)
(defvar jabberd-stanza-handlers '(jabberd-sasl jabberd-iq)
"List of stanza handler hooks.
These functions are called in order with two arguments, the
client FSM and the stanza, until one function returns non-nil,
indicating that it has handled the stanza.")
(defvar jabberd-iq-get-handlers
'(("jabber:iq:roster" . jabberd-iq-empty-success)
("jabber:iq:auth" . jabberd-iq-auth-get))
"Alist of handlers for IQ get stanzas.
The key is the namespace of the request (a string), and the value
is a function to handle the request. The function takes two
arguments, the client FSM and the stanza.")
(defvar jabberd-iq-set-handlers
'(("urn:ietf:params:xml:ns:xmpp-bind" . jabberd-iq-bind)
("urn:ietf:params:xml:ns:xmpp-session" . jabberd-iq-empty-success)
("jabber:iq:auth" . jabberd-iq-empty-success))
"Alist of handlers for IQ set stanzas.
The key is the namespace of the request (a string), and the value
is a function to handle the request. The function takes two
arguments, the client FSM and the stanza.")
(defun jabberd-connect ()
(setq *jabber-virtual-server-function* #'jabberd-handle)
(jabber-connect "romeo" "montague.net" nil nil "foo" nil nil 'virtual))
(defun jabberd-handle (fsm text)
;; First, parse stanzas from text into sexps.
(let (stanzas)
(with-temp-buffer
(insert text)
(goto-char (point-min))
;; Skip processing directive
(when (looking-at "<\\?xml[^?]*\\?>")
(delete-region (match-beginning 0) (match-end 0)))
(catch 'unfinished
(while t
(push
(if (prog1
(looking-at "<stream:stream")
(jabber-xml-skip-tag-forward t))
;; Stream start - just leave as a string
(delete-and-extract-region (point-min) (point))
;; Normal stanza
(prog1
(car (xml-parse-region (point-min) (point)))
(delete-region (point-min) (point))))
stanzas)))
;; Delete whitespace - it has already been skipped over by
;; jabber-xml-skip-tag-forward
(let ((whitespace-starts
(save-excursion (skip-chars-backward " \t\r\n") (point))))
(delete-region whitespace-starts (point)))
(unless (= (buffer-size) 0)
(error "Couldn't parse outgoing XML: %S; %S remaining" text (buffer-string))))
(setq stanzas (nreverse stanzas))
;; Now, let's handle the stanza(s).
(dolist (stanza stanzas)
(cond
((stringp stanza)
;; "Send" a stream start in return.
(fsm-send fsm (list :stream-start "42" "1.0"))
;; If we have a stream start, see whether it wants XMPP 1.0.
;; If so, send <stream:features>.
(when (string-match "version=[\"']" stanza)
(jabberd-send fsm
'(features
((xmlns . "http://etherx.jabber.org/streams"))
;; Interesting implementation details
;; of jabber.el permit us to send all
;; features at once, without caring about
;; which step we are at.
(mechanisms
((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
(mechanism () "DIGEST-MD5"))
(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")))
(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session")))))))
(t
(run-hook-with-args-until-success 'jabberd-stanza-handlers fsm stanza))))))
(defun jabberd-send (fsm stanza)
(jabber-log-xml fsm "receive" stanza)
(fsm-send fsm (list :stanza stanza)))
(defun jabberd-sasl (fsm stanza)
"Pretend to authenticate the client by SASL."
(when (eq (jabber-xml-node-name stanza) 'auth)
(jabberd-send fsm '(success ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))))
t))
(defun jabberd-iq (fsm stanza)
"Handle IQs from the client."
(when (eq (jabber-xml-node-name stanza) 'iq)
(jabber-xml-let-attributes (type id) stanza
(cond
((member type '("get" "set"))
(let* ((table (if (string= type "get")
jabberd-iq-get-handlers
jabberd-iq-set-handlers))
(ns (jabber-iq-xmlns stanza))
(function (cdr (assoc ns table))))
(when function
(funcall function fsm stanza)))))
t)))
(defun jabberd-iq-empty-success (fsm stanza)
"Send an empty IQ result to STANZA."
(jabber-xml-let-attributes (id) stanza
(jabberd-send
fsm
`(iq ((type . "result") (id . ,id))))))
(defun jabberd-iq-bind (fsm stanza)
"Do resource binding for the virtual server."
(let ((id (jabber-xml-get-attribute stanza 'id)))
(jabberd-send
fsm
`(iq ((type . "result") (id . ,id))
(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))
(jid () "romeo@montague.net/Orchard"))))))
(defun jabberd-iq-auth-get (fsm stanza)
(jabber-xml-let-attributes (id) stanza
(jabberd-send
fsm
`(iq ((type . "result") (id . ,id))
(query ((xmlns . "jabber:iq:auth"))
(username) (password) (digest) (resource))))))
(provide 'jabberd)
|
