Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 421 lines (353 sloc) 13.955 kb
c45064ac »
2009-04-02 seed
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
5577f236 »
2009-04-16 still no SASL
31 ;;; - plaintext sessions on port 5222
32 ;;; - "old sytle" ssl sessions on port 5223 (default)
c45064ac »
2009-04-02 seed
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
ebde9b3d »
2009-05-22 initial support for rosters
38 ;;; - basic roster handling (rfc 3921 sec.7)
c45064ac »
2009-04-02 seed
39 ;;;
40 ;;; features to implement
41 ;;; - account creation
ebde9b3d »
2009-05-22 initial support for rosters
42 ;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
43 ;;; - error handling for rosters (rfc 3921 sec.7)
c45064ac »
2009-04-02 seed
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
ebde9b3d »
2009-05-22 initial support for rosters
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
5577f236 »
2009-04-16 still no SASL
60 ;;; - coroutines for sasl negotiation
c45064ac »
2009-04-02 seed
61 ;;; - read-async & repsonse-handler
62 ;;; - ssax:xml->sxml or lazy:xml->sxml
63 ;;; - default handlers
5577f236 »
2009-04-16 still no SASL
64 ;;; - syntax for defining sxpath based handlers
65 ;;; - improve parsing
c45064ac »
2009-04-02 seed
66 ;;; - chatbot exmples
5577f236 »
2009-04-16 still no SASL
67 ;;;
c45064ac »
2009-04-02 seed
68
69 (module xmpp scheme
ebde9b3d »
2009-05-22 initial support for rosters
70
5577f236 »
2009-04-16 still no SASL
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
ebde9b3d »
2009-05-22 initial support for rosters
77
a84b6dcd »
2009-04-18 PLaneT update
78 (provide (all-defined-out))
c45064ac »
2009-04-02 seed
79
ebde9b3d »
2009-05-22 initial support for rosters
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
c45064ac »
2009-04-02 seed
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)
ebde9b3d »
2009-05-22 initial support for rosters
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' >"))
c45064ac »
2009-04-02 seed
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
5577f236 »
2009-04-16 still no SASL
156 (define (presence #:from (from "")
c45064ac »
2009-04-02 seed
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
5577f236 »
2009-04-16 still no SASL
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))))
c45064ac »
2009-04-02 seed
173
174 ;; curried stanza disection (sxml stanza -> string)
ebde9b3d »
2009-05-22 initial support for rosters
175 (define ((sxpath-element xpath (ns "")) stanza)
176 (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
c45064ac »
2009-04-02 seed
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()"))
ebde9b3d »
2009-05-22 initial support for rosters
198
199
a84b6dcd »
2009-04-18 PLaneT update
200 ;;;;;;;;;; ; ; ; ;; ;
201 ;;
202 ;; rosters
203 ;;
204 ;;;;;; ; ;; ;
ebde9b3d »
2009-05-22 initial support for rosters
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"))))))
c45064ac »
2009-04-02 seed
241
5577f236 »
2009-04-16 still no SASL
242 ;;;; ;; ; ;;; ;
243 ;;
244 ;; tls & sasl
245 ;; - http://xmpp.org/rfcs/rfc3920.html#tls
246 ;; - http://xmpp.org/rfcs/rfc3920.html#sasl
247 ;;
248 ;;;; ;;
db9fdaab »
2009-04-17 defmacro -> define-syntax
249
5577f236 »
2009-04-16 still no SASL
250 (define session->tls? #f) ;; changes state when a tls proceed is recived
251
252 ;; moved to xmpp-sasl until it 'works'
db9fdaab »
2009-04-17 defmacro -> define-syntax
253
c45064ac »
2009-04-02 seed
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
ebde9b3d »
2009-05-22 initial support for rosters
264 (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
c45064ac »
2009-04-02 seed
265
266 (define (set-xmpp-handler type fcn)
267 (dict-set! xmpp-handlers type fcn))
268
5577f236 »
2009-04-16 still no SASL
269 (define (remove-xmpp-handler type fcn)
270 (dict-remove! xmpp-handlers type fcn))
271
c45064ac »
2009-04-02 seed
272 (define (run-xmpp-handler type sz)
273 (let ((fcn (dict-ref xmpp-handlers type #f)))
274 (when fcn (begin
ebde9b3d »
2009-05-22 initial support for rosters
275 (debugf "attempting to run handler ~a.~%" fcn)
c45064ac »
2009-04-02 seed
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))
5577f236 »
2009-04-16 still no SASL
293 (else (run-xmpp-handler 'other sz))))))
c45064ac »
2009-04-02 seed
294
295 ;; example handlers to print stanzas or their contents
296 (define (print-message sz)
ebde9b3d »
2009-05-22 initial support for rosters
297 (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
c45064ac »
2009-04-02 seed
298
299 (define (print-iq sz)
ebde9b3d »
2009-05-22 initial support for rosters
300 (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
c45064ac »
2009-04-02 seed
301
302 (define (print-presence sz)
ebde9b3d »
2009-05-22 initial support for rosters
303 (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
c45064ac »
2009-04-02 seed
304
305 (define (print-stanza sz)
ebde9b3d »
2009-05-22 initial support for rosters
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))))
c45064ac »
2009-04-02 seed
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)
5577f236 »
2009-04-16 still no SASL
327 ((string-ci=? test "<ur") str)
328 (else
ebde9b3d »
2009-05-22 initial support for rosters
329 (debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
5577f236 »
2009-04-16 still no SASL
330 "<null/>"))))
c45064ac »
2009-04-02 seed
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)))))
5577f236 »
2009-04-16 still no SASL
357
c45064ac »
2009-04-02 seed
358
359 ;;;; ;; ; ; ;; ;; ;;;; ;
360 ;;
361 ;; interfaces
362 ;;
363 ;;;;; ;; ;;;; ; ;; ;
364
ebde9b3d »
2009-05-22 initial support for rosters
365 (define xmpp-in-port (make-parameter #f))
366 (define xmpp-out-port (make-parameter #F))
5577f236 »
2009-04-16 still no SASL
367
368 (define (send str)
ebde9b3d »
2009-05-22 initial support for rosters
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
db9fdaab »
2009-04-17 defmacro -> define-syntax
374 (define-syntax with-xmpp-session
375 (syntax-rules ()
a84b6dcd »
2009-04-18 PLaneT update
376 ((_ jid pass form . forms)
db9fdaab »
2009-04-17 defmacro -> define-syntax
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)))
ebde9b3d »
2009-05-22 initial support for rosters
382 ;;(tcp-connect host port)))
db9fdaab »
2009-04-17 defmacro -> define-syntax
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)
ebde9b3d »
2009-05-22 initial support for rosters
390 (send (xmpp-auth user pass resource))
db9fdaab »
2009-04-17 defmacro -> define-syntax
391 (send (presence))
a84b6dcd »
2009-04-18 PLaneT update
392 (begin form . forms)
db9fdaab »
2009-04-17 defmacro -> define-syntax
393 (close-output-port out)
394 (close-input-port in)))))))
c45064ac »
2009-04-02 seed
395
ebde9b3d »
2009-05-22 initial support for rosters
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
c45064ac »
2009-04-02 seed
421 ) ;; end module
ebde9b3d »
2009-05-22 initial support for rosters
422
Something went wrong with that request. Please try again.