Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 423 lines (353 sloc) 13.955 kb
c45064a nik gaffney seed
authored
1 ;;; A basic XMPP library which should conform to RFCs 3920 and 3921
2 ;;;
3 ;;; Copyright (C) 2009 FoAM vzw.
4 ;;;
5 ;;; This package is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation, either
8 ;;; version 3 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Lesser General Public License for more details.
14 ;;;
15 ;;; You can find a copy of the GNU Lesser General Public License at
16 ;;; http://www.gnu.org/licenses/lgpl-3.0.html.
17 ;;;
18 ;;; Authors
19 ;;;
20 ;;; nik gaffney <nik@fo.am>
21 ;;;
22 ;;; Requirements
23 ;;;
24 ;;; PLT for now. TLS requires a version of PLT > 4.1.5.3
25 ;;;
26 ;;; Commentary
27 ;;;
28 ;;; Still a long way from implementing even a minimal subset of XMPP
29 ;;;
30 ;;; features implemented
5577f23 nik gaffney still no SASL
authored
31 ;;; - plaintext sessions on port 5222
32 ;;; - "old sytle" ssl sessions on port 5223 (default)
c45064a nik gaffney seed
authored
33 ;;; - authenticate using an existing account
34 ;;; - send messages (rfc 3921 sec.4)
35 ;;; - send presence (rfc 3921 sec.5)
36 ;;; - parse (some) xml reponses from server
37 ;;; - handlers for responses
ebde9b3 nik gaffney initial support for rosters
authored
38 ;;; - basic roster handling (rfc 3921 sec.7)
c45064a nik gaffney seed
authored
39 ;;;
40 ;;; features to implement
41 ;;; - account creation
ebde9b3 nik gaffney initial support for rosters
authored
42 ;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
43 ;;; - error handling for rosters (rfc 3921 sec.7)
c45064a nik gaffney seed
authored
44 ;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6)
45 ;;; - encrypted connections using tls on port 5222
46 ;;; - correct namespaces in sxml
47 ;;; - message types
48 ;;; - maintain session ids
49 ;;; - maintain threads
50 ;;; - error handling
51 ;;; - events
52 ;;; - [...]
53 ;;; - rfc 3920
54 ;;; - rfc 3921
55 ;;;
56 ;;; bugs and/or improvements
ebde9b3 nik gaffney initial support for rosters
authored
57 ;;; - start & stop functions for multiple sessions
58 ;;; - pubsub (XEP-0060) & group chats (XEP-0045)
59 ;;; - 'send' using call/cc & parameterize'd i/o ports
5577f23 nik gaffney still no SASL
authored
60 ;;; - coroutines for sasl negotiation
c45064a nik gaffney seed
authored
61 ;;; - read-async & repsonse-handler
62 ;;; - ssax:xml->sxml or lazy:xml->sxml
63 ;;; - default handlers
5577f23 nik gaffney still no SASL
authored
64 ;;; - syntax for defining sxpath based handlers
65 ;;; - improve parsing
c45064a nik gaffney seed
authored
66 ;;; - chatbot exmples
5577f23 nik gaffney still no SASL
authored
67 ;;;
c45064a nik gaffney seed
authored
68
69 (module xmpp scheme
ebde9b3 nik gaffney initial support for rosters
authored
70
5577f23 nik gaffney still no SASL
authored
71 (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
72 (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
73 (require mzlib/os) ;; hostname
74 (require scheme/tcp) ;; networking
75 (require openssl) ;; ssl/tls
76 (require srfi/13) ;; jid decoding
ebde9b3 nik gaffney initial support for rosters
authored
77
a84b6dc nik gaffney PLaneT update
authored
78 (provide (all-defined-out))
c45064a nik gaffney seed
authored
79
ebde9b3 nik gaffney initial support for rosters
authored
80 ;;;; ; ;; ;
81 ;;
82 ;; debugging
83 ;;
84 ;;;; ; ;
85
86 (define debug? #t)
87
88 (define debugf
89 (case-lambda
90 ((str) (when debug? (printf str)))
91 ((str . dir) (when debug? (apply printf (cons str dir))))))
92
c45064a nik gaffney seed
authored
93 ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
94 ;;
95 ;; networking
96 ;;
97 ;;;;;; ;; ;; ; ; ; ;
98
99 (define port 5222)
100 (define ssl-port 5223)
101
102 (define (open-connection machine port handler)
103 (let-values (((in out)
104 (tcp-connect machine port)))
105 (handler in out)
106 (close-output-port out)
107 (close-input-port in)))
108
109 (define (open-ssl-connection machine port handler)
110 (let-values (((in out)
111 (ssl-connect machine port 'tls)))
112 (handler in out)
113 (close-output-port out)
114 (close-input-port in)))
115
116 (define (read-async in)
117 (bytes->string/utf-8 (list->bytes (read-async-bytes in))))
118
119 (define (read-async-bytes in)
120 (let ((bstr '()))
121 (when (sync/timeout 0 in)
122 (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr))
123
124 (define ssxml srl:sxml->xml-noindent)
125
126 ;;;;;; ; ; ; ; ;; ;;;;;; ;
127 ;;
128 ;; XMPP stanzas
129 ;;
130 ;;;;;;;;;; ;;; ; ;; ; ;
131
132 ;; intialization
133 (define (xmpp-stream host)
ebde9b3 nik gaffney initial support for rosters
authored
134 (string-append "<?xml version='1.0'?>" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223
135 "<stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='"
136 host
137 "' xmlns='jabber:client' >"))
c45064a nik gaffney seed
authored
138
139 ;; authentication
140 (define (xmpp-auth username password resource)
141 (ssxml `(iq (@ (type "set") (id "auth"))
142 (query (@ (xmlns "jabber:iq:auth"))
143 (username ,username)
144 (password ,password)
145 (resource ,resource)))))
146
147 (define (xmpp-session host)
148 (ssxml `(iq (@ (to ,host) (type "set") (id "session"))
149 (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session"))))))
150
151 ;; messages
152 (define (message to body)
153 (ssxml `(message (@ (to ,to)) (body ,body))))
154
155 ;; presence
5577f23 nik gaffney still no SASL
authored
156 (define (presence #:from (from "")
c45064a nik gaffney seed
authored
157 #:to (to "")
158 #:type (type "")
159 #:show (show "")
160 #:status (status ""))
161 (cond ((not (string=? status ""))
162 (ssxml `(presence (@ (type "probe")) (status ,status))))
163 ((string=? type "") "<presence/>")
164 (else (ssxml `(presence (@ (type ,type)))))))
165
5577f23 nik gaffney still no SASL
authored
166 ;; queries
167 (define (iq body
168 #:from (from "")
169 #:to (to "")
170 #:type (type "")
171 #:id (id ""))
172 (ssxml `(iq (@ (to ,to) (type ,type) ,body))))
c45064a nik gaffney seed
authored
173
174 ;; curried stanza disection (sxml stanza -> string)
ebde9b3 nik gaffney initial support for rosters
authored
175 (define ((sxpath-element xpath (ns "")) stanza)
176 (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
c45064a nik gaffney seed
authored
177 (if (empty? node) "" (car node))))
178
179 ;; message
180 (define message-from (sxpath-element "message/@from/text()"))
181 (define message-to (sxpath-element "message/@to/text()"))
182 (define message-id (sxpath-element "message/@id/text()"))
183 (define message-type (sxpath-element "message/@type/text()"))
184 (define message-body (sxpath-element "message/body/text()"))
185 (define message-subject (sxpath-element "message/subject/text()"))
186
187 ;; info/query
188 (define iq-type (sxpath-element "iq/@type/text()"))
189 (define iq-id (sxpath-element "iq/@id/text()"))
190 (define iq-error-type (sxpath-element "iq/error/@type/text()"))
191 (define iq-error-text (sxpath-element "iq/error/text()"))
192 (define iq-error (sxpath-element "iq/error"))
193
194 ;; presence
195 (define presence-show (sxpath-element "presence/show/text()"))
196 (define presence-from (sxpath-element "presence/@from/text()"))
197 (define presence-status (sxpath-element "presence/status/text()"))
ebde9b3 nik gaffney initial support for rosters
authored
198
199
a84b6dc nik gaffney PLaneT update
authored
200 ;;;;;;;;;; ; ; ; ;; ;
201 ;;
202 ;; rosters
203 ;;
204 ;;;;;; ; ;; ;
ebde9b3 nik gaffney initial support for rosters
authored
205
206 ;; request the roster from server
207 (define (request-roster from)
208 (ssxml `(iq (@ (from ,from) (type "get") (id "roster_1"))
209 (query (@ (xmlns "jabber:iq:roster"))))))
210
211 ;; add an item to the roster
212 (define (add-to-roster from jid name group)
213 (ssxml `(iq (@ (from ,from) (type "set") (id "roster_2"))
214 (query (@ (xmlns "jabber:iq:roster"))
215 (item (@ (jid ,jid) (name ,name))
216 (group ,group))))))
217
218 ;; update an item in the roster
219 (define (update-roster from jid name group)
220 (ssxml `(iq (@ (from ,from) (type "set") (id "roster_3"))
221 (query (@ (xmlns "jabber:iq:roster"))
222 (item (@ (jid ,jid) (name ,name))
223 (group ,group))))))
224
225 ;; remove an item from the roster
226 (define (remove-from-roster from jid)
227 (ssxml `(iq (@ (from ,from) (type "set") (id "roster_4"))
228 (query (@ (xmlns "jabber:iq:roster"))
229 (item (@ (jid ,jid) (subscription "remove")))))))
230
231
232 ;;;;; ; ; ;; ; ;
233 ;;
234 ;; in-band registration
235 ;;
236 ;;;;;; ;; ;; ;
237
238 (define (reg1)
239 (ssxml `(iq (@ (type "get") (id "reg1"))
240 (query (@ (xmlns "jabber:iq:register"))))))
c45064a nik gaffney seed
authored
241
5577f23 nik gaffney still no SASL
authored
242 ;;;; ;; ; ;;; ;
243 ;;
244 ;; tls & sasl
245 ;; - http://xmpp.org/rfcs/rfc3920.html#tls
246 ;; - http://xmpp.org/rfcs/rfc3920.html#sasl
247 ;;
248 ;;;; ;;
db9fdaa nik gaffney defmacro -> define-syntax
authored
249
5577f23 nik gaffney still no SASL
authored
250 (define session->tls? #f) ;; changes state when a tls proceed is recived
251
252 ;; moved to xmpp-sasl until it 'works'
db9fdaa nik gaffney defmacro -> define-syntax
authored
253
c45064a nik gaffney seed
authored
254
255 ;;;;;;;;; ; ;; ; ; ;; ;; ; ;
256 ;;
257 ;; parsing & message/iq/error handlers
258 ;; - minimal parsing
259 ;; - handlers match on a tag (eg. 'message)
260 ;; - handlers are called with a single relevant xmpp stanza
261 ;;
262 ;;;;;; ;; ; ; ;; ;
263
ebde9b3 nik gaffney initial support for rosters
authored
264 (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
c45064a nik gaffney seed
authored
265
266 (define (set-xmpp-handler type fcn)
267 (dict-set! xmpp-handlers type fcn))
268
5577f23 nik gaffney still no SASL
authored
269 (define (remove-xmpp-handler type fcn)
270 (dict-remove! xmpp-handlers type fcn))
271
c45064a nik gaffney seed
authored
272 (define (run-xmpp-handler type sz)
273 (let ((fcn (dict-ref xmpp-handlers type #f)))
274 (when fcn (begin
ebde9b3 nik gaffney initial support for rosters
authored
275 (debugf "attempting to run handler ~a.~%" fcn)
c45064a nik gaffney seed
authored
276 (fcn sz)))))
277
278 ;; no real parsing yet. dispatches any received xml stanzas as sxml
279
280 (define (parse-xmpp-response str)
281 (when (> (string-length str) 0)
282 (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '())))
283 ;;(let ((sz (lazy:xml->sxml (open-input-string str) '())))
284 (cond
285 ((equal? '(null) (cadr sz))
286 (newline))
287 ((equal? 'message (caadr sz))
288 (run-xmpp-handler 'message sz))
289 ((equal? 'iq (caadr sz))
290 (run-xmpp-handler 'iq sz))
291 ((equal? 'presence (caadr sz))
292 (run-xmpp-handler 'presence sz))
5577f23 nik gaffney still no SASL
authored
293 (else (run-xmpp-handler 'other sz))))))
c45064a nik gaffney seed
authored
294
295 ;; example handlers to print stanzas or their contents
296 (define (print-message sz)
ebde9b3 nik gaffney initial support for rosters
authored
297 (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
c45064a nik gaffney seed
authored
298
299 (define (print-iq sz)
ebde9b3 nik gaffney initial support for rosters
authored
300 (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
c45064a nik gaffney seed
authored
301
302 (define (print-presence sz)
ebde9b3 nik gaffney initial support for rosters
authored
303 (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
c45064a nik gaffney seed
authored
304
305 (define (print-stanza sz)
ebde9b3 nik gaffney initial support for rosters
authored
306 (printf "? ?? -> ~%~a~%" sz))
307
308 ;; handler to print roster
309
310 (define (roster-jids sz)
311 ((sxpath "iq/ns:query/ns:item/@jid/text()" '(( ns . "jabber:iq:roster"))) sz))
312
313 (define (roster-items sz)
314 ((sxpath-element "iq/ns:query/ns:item" '(( ns . "jabber:iq:roster"))) sz))
315
316 (define (print-roster sz)
317 (when (and (string=? (iq-type sz) "result")
318 (string=? (iq-id sz) "roster_1"))
319 (printf "~a~%" (roster-jids sz))))
c45064a nik gaffney seed
authored
320
321 ;; QND hack to filter out anything not a message, iq or presence
322 (define (clean str)
323 (let ((test (substring str 0 3)))
324 (cond ((string-ci=? test "<me") str)
325 ((string-ci=? test "<iq") str)
326 ((string-ci=? test "<pr") str)
5577f23 nik gaffney still no SASL
authored
327 ((string-ci=? test "<ur") str)
328 (else
ebde9b3 nik gaffney initial support for rosters
authored
329 (debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
5577f23 nik gaffney still no SASL
authored
330 "<null/>"))))
c45064a nik gaffney seed
authored
331
332
333 ;; response handler
334 (define (xmpp-response-handler in)
335 (thread (lambda ()
336 (let loop ()
337 (parse-xmpp-response (read-async in))
338 (sleep 0.1) ;; slight delay to avoid a tight loop
339 (loop)))))
340
341 ;; jid splicing (assuming the jid is in the format user@host/resource)
342 (define (jid-user jid)
343 (string-take jid (string-index jid #\@)))
344
345 (define (jid-host jid)
346 (let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1)))
347 (v (string-index s #\/)))
348 (if v (string-take s v) s )))
349
350 (define (jid-resource jid)
351 (let ((r (jid-resource-0 jid)))
352 (if (void? r) (gethostname) r)))
353
354 (define (jid-resource-0 jid)
355 (let ((v (string-index jid #\/)))
356 (when v (string-take-right jid (- (string-length jid) v 1)))))
5577f23 nik gaffney still no SASL
authored
357
c45064a nik gaffney seed
authored
358
359 ;;;; ;; ; ; ;; ;; ;;;; ;
360 ;;
361 ;; interfaces
362 ;;
363 ;;;;; ;; ;;;; ; ;; ;
364
ebde9b3 nik gaffney initial support for rosters
authored
365 (define xmpp-in-port (make-parameter #f))
366 (define xmpp-out-port (make-parameter #F))
5577f23 nik gaffney still no SASL
authored
367
368 (define (send str)
ebde9b3 nik gaffney initial support for rosters
authored
369 (debugf "sending: ~a ~%~%" str)
370 (let* ((p-out (xmpp-out-port))
371 (out (if p-out p-out xmpp-out-port-v)))
372 (fprintf out "~A~%" str) (flush-output out)))
373
db9fdaa nik gaffney defmacro -> define-syntax
authored
374 (define-syntax with-xmpp-session
375 (syntax-rules ()
a84b6dc nik gaffney PLaneT update
authored
376 ((_ jid pass form . forms)
db9fdaa nik gaffney defmacro -> define-syntax
authored
377 (let ((host (jid-host jid))
378 (user (jid-user jid))
379 (resource (jid-resource jid)))
380 (let-values (((in out)
381 (ssl-connect host ssl-port 'tls)))
ebde9b3 nik gaffney initial support for rosters
authored
382 ;;(tcp-connect host port)))
db9fdaa nik gaffney defmacro -> define-syntax
authored
383 (parameterize ((xmpp-in-port in)
384 (xmpp-out-port out))
385 (file-stream-buffer-mode out 'line)
386 (xmpp-response-handler in)
387 (send (xmpp-stream host))
388 (send (xmpp-session host))
389 ;(starttls in out)
ebde9b3 nik gaffney initial support for rosters
authored
390 (send (xmpp-auth user pass resource))
db9fdaa nik gaffney defmacro -> define-syntax
authored
391 (send (presence))
a84b6dc nik gaffney PLaneT update
authored
392 (begin form . forms)
db9fdaa nik gaffney defmacro -> define-syntax
authored
393 (close-output-port out)
394 (close-input-port in)))))))
c45064a nik gaffney seed
authored
395
ebde9b3 nik gaffney initial support for rosters
authored
396 ;; NOTE: this will only work with a single connection to a host, however multiple sessions to that host may be possible
397 (define xmpp-in-port-v (current-input-port))
398 (define xmpp-out-port-v (current-output-port))
399
400 (define (start-xmpp-session jid pass)
401 (let ((host (jid-host jid))
402 (user (jid-user jid))
403 (resource (jid-resource jid)))
404 (let-values (((in out)
405 (ssl-connect host ssl-port 'tls)))
406 ;;(tcp-connect host port)))
407 (set! xmpp-in-port-v in)
408 (set! xmpp-out-port-v out)
409 (file-stream-buffer-mode out 'line)
410 (xmpp-response-handler in)
411 (send (xmpp-stream host))
412 (send (xmpp-session host))
413 ;;(starttls in out)
414 (send (xmpp-auth user pass resource))
415 (send (presence)))))
416
417 (define (close-xmpp-session)
418 (close-output-port xmpp-out-port-v)
419 (close-input-port xmpp-in-port-v))
420
c45064a nik gaffney seed
authored
421 ) ;; end module
ebde9b3 nik gaffney initial support for rosters
authored
422
Something went wrong with that request. Please try again.