Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initial support for rosters

  • Loading branch information...
commit ebde9b3d5ee2319f3e77198729fd0e0558f16225 1 parent a84b6dc
nik gaffney authored

Showing 2 changed files with 142 additions and 29 deletions. Show diff stats Hide diff stats

  1. +22 1 xmpp.scrbl
  2. +120 28 xmpp.ss
23 xmpp.scrbl
@@ -7,6 +7,15 @@ A module for using the Jabber/XMPP protocol.
7 7
8 8 @table-of-contents[]
9 9
  10 +@section{Require}
  11 +
  12 +@scheme[(require (planet zzkt/xmpp))]
  13 +
  14 +If you are using @scheme[send] provided from @scheme[scheme/class] you
  15 +should use a prefix to avoid a name clash with @scheme[send].
  16 +
  17 +@scheme[(require (prefix-in xmpp: (planet zzkt/xmpp)))]
  18 +
10 19 @section{Protocol Support}
11 20
12 21 A minimal subset of the XMPP protocols are supported, but not much
@@ -24,7 +33,7 @@ It is necessary to establish a session with a Jabber server before
24 33 sending any messages or presence updates. This can be done manually,
25 34 or with the help of with-xmpp-session.
26 35
27   -@defform[(with-xmpp-seesion [jid jid?] [password string?] body)]{
  36 +@defform[(with-xmpp-session [jid jid?] [password string?] body)]{
28 37
29 38 Establishes an XMPP session using the id @scheme[jid] and password
30 39 @scheme[pass] and evaluates the forms in @scheme[body] in the
@@ -65,6 +74,18 @@ To send a message containing @scheme[text] to a user with the
65 74 (set-xmpp-handler 'message print-message))
66 75 ]
67 76
  77 +@section{Rosters}
  78 +
  79 +@schemeblock[
  80 +(with-xmpp-session jid pass
  81 + (send (request-roster jid)))
  82 +]
  83 +
  84 +@schemeblock[
  85 +(with-xmpp-session jid1 pass
  86 + (send (add-to-roster jid1 jid2 name group)))
  87 +]
  88 +
68 89 @section{Example Chat Client}
69 90
70 91 @schemeblock[
148 xmpp.ss
@@ -35,11 +35,12 @@
35 35 ;;; - send presence (rfc 3921 sec.5)
36 36 ;;; - parse (some) xml reponses from server
37 37 ;;; - handlers for responses
  38 +;;; - basic roster handling (rfc 3921 sec.7)
38 39 ;;;
39 40 ;;; features to implement
40 41 ;;; - account creation
41   -;;; - managing subscriptions (rfc 3921 sec.6)
42   -;;; - rosters (rfc 3921 sec.7)
  42 +;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
  43 +;;; - error handling for rosters (rfc 3921 sec.7)
43 44 ;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6)
44 45 ;;; - encrypted connections using tls on port 5222
45 46 ;;; - correct namespaces in sxml
@@ -53,8 +54,9 @@
53 54 ;;; - rfc 3921
54 55 ;;;
55 56 ;;; bugs and/or improvements
56   -;;; - PLaneT installable
57   -;;; - 'send' using call/cc vs 'parameter' i/o ports
  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
58 60 ;;; - coroutines for sasl negotiation
59 61 ;;; - read-async & repsonse-handler
60 62 ;;; - ssax:xml->sxml or lazy:xml->sxml
@@ -65,16 +67,29 @@
65 67 ;;;
66 68
67 69 (module xmpp scheme
68   -
  70 +
69 71 (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
70 72 (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
71 73 (require mzlib/os) ;; hostname
72 74 (require scheme/tcp) ;; networking
73 75 (require openssl) ;; ssl/tls
74 76 (require srfi/13) ;; jid decoding
75   -
  77 +
76 78 (provide (all-defined-out))
77 79
  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 +
78 93 ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
79 94 ;;
80 95 ;; networking
@@ -116,7 +131,10 @@
116 131
117 132 ;; intialization
118 133 (define (xmpp-stream host)
119   - (string-append "<?xml version='1.0'?><stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='" host "' xmlns='jabber:client' >")) ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223
  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' >"))
120 138
121 139 ;; authentication
122 140 (define (xmpp-auth username password resource)
@@ -154,8 +172,8 @@
154 172 (ssxml `(iq (@ (to ,to) (type ,type) ,body))))
155 173
156 174 ;; curried stanza disection (sxml stanza -> string)
157   - (define ((sxpath-element xpath) stanza)
158   - (let ((node ((sxpath xpath) stanza)))
  175 + (define ((sxpath-element xpath (ns "")) stanza)
  176 + (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
159 177 (if (empty? node) "" (car node))))
160 178
161 179 ;; message
@@ -177,15 +195,49 @@
177 195 (define presence-show (sxpath-element "presence/show/text()"))
178 196 (define presence-from (sxpath-element "presence/@from/text()"))
179 197 (define presence-status (sxpath-element "presence/status/text()"))
180   -
181   -
  198 +
  199 +
182 200 ;;;;;;;;;; ; ; ; ;; ;
183 201 ;;
184 202 ;; rosters
185 203 ;;
186 204 ;;;;;; ; ;; ;
187   -
188   -
  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"))))))
189 241
190 242 ;;;; ;; ; ;;; ;
191 243 ;;
@@ -209,7 +261,7 @@
209 261 ;;
210 262 ;;;;;; ;; ; ; ;; ;
211 263
212   - (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths)
  264 + (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
213 265
214 266 (define (set-xmpp-handler type fcn)
215 267 (dict-set! xmpp-handlers type fcn))
@@ -220,7 +272,7 @@
220 272 (define (run-xmpp-handler type sz)
221 273 (let ((fcn (dict-ref xmpp-handlers type #f)))
222 274 (when fcn (begin
223   - (display (format "attempting to run handler ~a.~%" fcn))
  275 + (debugf "attempting to run handler ~a.~%" fcn)
224 276 (fcn sz)))))
225 277
226 278 ;; no real parsing yet. dispatches any received xml stanzas as sxml
@@ -242,16 +294,29 @@
242 294
243 295 ;; example handlers to print stanzas or their contents
244 296 (define (print-message sz)
245   - (display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz))))
  297 + (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
246 298
247 299 (define (print-iq sz)
248   - (display (format "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz))))
  300 + (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
249 301
250 302 (define (print-presence sz)
251   - (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status))))
  303 + (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
252 304
253 305 (define (print-stanza sz)
254   - (display (format "? ?? -> ~%~a~%" sz)))
  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))))
255 320
256 321 ;; QND hack to filter out anything not a message, iq or presence
257 322 (define (clean str)
@@ -261,7 +326,7 @@
261 326 ((string-ci=? test "<pr") str)
262 327 ((string-ci=? test "<ur") str)
263 328 (else
264   - (display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
  329 + (debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
265 330 "<null/>"))))
266 331
267 332
@@ -297,13 +362,15 @@
297 362 ;;
298 363 ;;;;; ;; ;;;; ; ;; ;
299 364
300   - (define xmpp-in-port (make-parameter (current-input-port)))
301   - (define xmpp-out-port (make-parameter (current-output-port)))
  365 + (define xmpp-in-port (make-parameter #f))
  366 + (define xmpp-out-port (make-parameter #F))
302 367
303 368 (define (send str)
304   - (printf "sending iO: ~a ~%~%" str)
305   - (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
306   -
  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 +
307 374 (define-syntax with-xmpp-session
308 375 (syntax-rules ()
309 376 ((_ jid pass form . forms)
@@ -312,7 +379,7 @@
312 379 (resource (jid-resource jid)))
313 380 (let-values (((in out)
314 381 (ssl-connect host ssl-port 'tls)))
315   - ;;(tcp-connect host port)))
  382 + ;;(tcp-connect host port)))
316 383 (parameterize ((xmpp-in-port in)
317 384 (xmpp-out-port out))
318 385 (file-stream-buffer-mode out 'line)
@@ -320,11 +387,36 @@
320 387 (send (xmpp-stream host))
321 388 (send (xmpp-session host))
322 389 ;(starttls in out)
323   - (send (xmpp-auth user pass resource))
  390 + (send (xmpp-auth user pass resource))
324 391 (send (presence))
325   - (send (presence #:status "Available"))
326 392 (begin form . forms)
327 393 (close-output-port out)
328 394 (close-input-port in)))))))
329 395
  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 +
330 421 ) ;; end module
  422 +

0 comments on commit ebde9b3

Please sign in to comment.
Something went wrong with that request. Please try again.