Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial support for rosters

  • Loading branch information...
commit ebde9b3d5ee2319f3e77198729fd0e0558f16225 1 parent a84b6dc
@zzkt authored
Showing with 142 additions and 29 deletions.
  1. +22 −1 xmpp.scrbl
  2. +120 −28 xmpp.ss
View
23 xmpp.scrbl
@@ -7,6 +7,15 @@ A module for using the Jabber/XMPP protocol.
@table-of-contents[]
+@section{Require}
+
+@scheme[(require (planet zzkt/xmpp))]
+
+If you are using @scheme[send] provided from @scheme[scheme/class] you
+should use a prefix to avoid a name clash with @scheme[send].
+
+@scheme[(require (prefix-in xmpp: (planet zzkt/xmpp)))]
+
@section{Protocol Support}
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
sending any messages or presence updates. This can be done manually,
or with the help of with-xmpp-session.
-@defform[(with-xmpp-seesion [jid jid?] [password string?] body)]{
+@defform[(with-xmpp-session [jid jid?] [password string?] body)]{
Establishes an XMPP session using the id @scheme[jid] and password
@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
(set-xmpp-handler 'message print-message))
]
+@section{Rosters}
+
+@schemeblock[
+(with-xmpp-session jid pass
+ (send (request-roster jid)))
+]
+
+@schemeblock[
+(with-xmpp-session jid1 pass
+ (send (add-to-roster jid1 jid2 name group)))
+]
+
@section{Example Chat Client}
@schemeblock[
View
148 xmpp.ss
@@ -35,11 +35,12 @@
;;; - send presence (rfc 3921 sec.5)
;;; - parse (some) xml reponses from server
;;; - handlers for responses
+;;; - basic roster handling (rfc 3921 sec.7)
;;;
;;; features to implement
;;; - account creation
-;;; - managing subscriptions (rfc 3921 sec.6)
-;;; - rosters (rfc 3921 sec.7)
+;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
+;;; - error handling for rosters (rfc 3921 sec.7)
;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6)
;;; - encrypted connections using tls on port 5222
;;; - correct namespaces in sxml
@@ -53,8 +54,9 @@
;;; - rfc 3921
;;;
;;; bugs and/or improvements
-;;; - PLaneT installable
-;;; - 'send' using call/cc vs 'parameter' i/o ports
+;;; - start & stop functions for multiple sessions
+;;; - pubsub (XEP-0060) & group chats (XEP-0045)
+;;; - 'send' using call/cc & parameterize'd i/o ports
;;; - coroutines for sasl negotiation
;;; - read-async & repsonse-handler
;;; - ssax:xml->sxml or lazy:xml->sxml
@@ -65,16 +67,29 @@
;;;
(module xmpp scheme
-
+
(require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
(require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
(require mzlib/os) ;; hostname
(require scheme/tcp) ;; networking
(require openssl) ;; ssl/tls
(require srfi/13) ;; jid decoding
-
+
(provide (all-defined-out))
+ ;;;; ; ;; ;
+ ;;
+ ;; debugging
+ ;;
+ ;;;; ; ;
+
+ (define debug? #t)
+
+ (define debugf
+ (case-lambda
+ ((str) (when debug? (printf str)))
+ ((str . dir) (when debug? (apply printf (cons str dir))))))
+
;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
;;
;; networking
@@ -116,7 +131,10 @@
;; intialization
(define (xmpp-stream host)
- (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
+ (string-append "<?xml version='1.0'?>" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223
+ "<stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='"
+ host
+ "' xmlns='jabber:client' >"))
;; authentication
(define (xmpp-auth username password resource)
@@ -154,8 +172,8 @@
(ssxml `(iq (@ (to ,to) (type ,type) ,body))))
;; curried stanza disection (sxml stanza -> string)
- (define ((sxpath-element xpath) stanza)
- (let ((node ((sxpath xpath) stanza)))
+ (define ((sxpath-element xpath (ns "")) stanza)
+ (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
(if (empty? node) "" (car node))))
;; message
@@ -177,15 +195,49 @@
(define presence-show (sxpath-element "presence/show/text()"))
(define presence-from (sxpath-element "presence/@from/text()"))
(define presence-status (sxpath-element "presence/status/text()"))
-
-
+
+
;;;;;;;;;; ; ; ; ;; ;
;;
;; rosters
;;
;;;;;; ; ;; ;
-
-
+
+ ;; request the roster from server
+ (define (request-roster from)
+ (ssxml `(iq (@ (from ,from) (type "get") (id "roster_1"))
+ (query (@ (xmlns "jabber:iq:roster"))))))
+
+ ;; add an item to the roster
+ (define (add-to-roster from jid name group)
+ (ssxml `(iq (@ (from ,from) (type "set") (id "roster_2"))
+ (query (@ (xmlns "jabber:iq:roster"))
+ (item (@ (jid ,jid) (name ,name))
+ (group ,group))))))
+
+ ;; update an item in the roster
+ (define (update-roster from jid name group)
+ (ssxml `(iq (@ (from ,from) (type "set") (id "roster_3"))
+ (query (@ (xmlns "jabber:iq:roster"))
+ (item (@ (jid ,jid) (name ,name))
+ (group ,group))))))
+
+ ;; remove an item from the roster
+ (define (remove-from-roster from jid)
+ (ssxml `(iq (@ (from ,from) (type "set") (id "roster_4"))
+ (query (@ (xmlns "jabber:iq:roster"))
+ (item (@ (jid ,jid) (subscription "remove")))))))
+
+
+ ;;;;; ; ; ;; ; ;
+ ;;
+ ;; in-band registration
+ ;;
+ ;;;;;; ;; ;; ;
+
+ (define (reg1)
+ (ssxml `(iq (@ (type "get") (id "reg1"))
+ (query (@ (xmlns "jabber:iq:register"))))))
;;;; ;; ; ;;; ;
;;
@@ -209,7 +261,7 @@
;;
;;;;;; ;; ; ; ;; ;
- (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths)
+ (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
(define (set-xmpp-handler type fcn)
(dict-set! xmpp-handlers type fcn))
@@ -220,7 +272,7 @@
(define (run-xmpp-handler type sz)
(let ((fcn (dict-ref xmpp-handlers type #f)))
(when fcn (begin
- (display (format "attempting to run handler ~a.~%" fcn))
+ (debugf "attempting to run handler ~a.~%" fcn)
(fcn sz)))))
;; no real parsing yet. dispatches any received xml stanzas as sxml
@@ -242,16 +294,29 @@
;; example handlers to print stanzas or their contents
(define (print-message sz)
- (display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz))))
+ (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
(define (print-iq sz)
- (display (format "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz))))
+ (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
(define (print-presence sz)
- (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status))))
+ (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
(define (print-stanza sz)
- (display (format "? ?? -> ~%~a~%" sz)))
+ (printf "? ?? -> ~%~a~%" sz))
+
+ ;; handler to print roster
+
+ (define (roster-jids sz)
+ ((sxpath "iq/ns:query/ns:item/@jid/text()" '(( ns . "jabber:iq:roster"))) sz))
+
+ (define (roster-items sz)
+ ((sxpath-element "iq/ns:query/ns:item" '(( ns . "jabber:iq:roster"))) sz))
+
+ (define (print-roster sz)
+ (when (and (string=? (iq-type sz) "result")
+ (string=? (iq-id sz) "roster_1"))
+ (printf "~a~%" (roster-jids sz))))
;; QND hack to filter out anything not a message, iq or presence
(define (clean str)
@@ -261,7 +326,7 @@
((string-ci=? test "<pr") str)
((string-ci=? test "<ur") str)
(else
- (display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
+ (debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
"<null/>"))))
@@ -297,13 +362,15 @@
;;
;;;;; ;; ;;;; ; ;; ;
- (define xmpp-in-port (make-parameter (current-input-port)))
- (define xmpp-out-port (make-parameter (current-output-port)))
+ (define xmpp-in-port (make-parameter #f))
+ (define xmpp-out-port (make-parameter #F))
(define (send str)
- (printf "sending iO: ~a ~%~%" str)
- (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
-
+ (debugf "sending: ~a ~%~%" str)
+ (let* ((p-out (xmpp-out-port))
+ (out (if p-out p-out xmpp-out-port-v)))
+ (fprintf out "~A~%" str) (flush-output out)))
+
(define-syntax with-xmpp-session
(syntax-rules ()
((_ jid pass form . forms)
@@ -312,7 +379,7 @@
(resource (jid-resource jid)))
(let-values (((in out)
(ssl-connect host ssl-port 'tls)))
- ;;(tcp-connect host port)))
+ ;;(tcp-connect host port)))
(parameterize ((xmpp-in-port in)
(xmpp-out-port out))
(file-stream-buffer-mode out 'line)
@@ -320,11 +387,36 @@
(send (xmpp-stream host))
(send (xmpp-session host))
;(starttls in out)
- (send (xmpp-auth user pass resource))
+ (send (xmpp-auth user pass resource))
(send (presence))
- (send (presence #:status "Available"))
(begin form . forms)
(close-output-port out)
(close-input-port in)))))))
+ ;; NOTE: this will only work with a single connection to a host, however multiple sessions to that host may be possible
+ (define xmpp-in-port-v (current-input-port))
+ (define xmpp-out-port-v (current-output-port))
+
+ (define (start-xmpp-session jid pass)
+ (let ((host (jid-host jid))
+ (user (jid-user jid))
+ (resource (jid-resource jid)))
+ (let-values (((in out)
+ (ssl-connect host ssl-port 'tls)))
+ ;;(tcp-connect host port)))
+ (set! xmpp-in-port-v in)
+ (set! xmpp-out-port-v out)
+ (file-stream-buffer-mode out 'line)
+ (xmpp-response-handler in)
+ (send (xmpp-stream host))
+ (send (xmpp-session host))
+ ;;(starttls in out)
+ (send (xmpp-auth user pass resource))
+ (send (presence)))))
+
+ (define (close-xmpp-session)
+ (close-output-port xmpp-out-port-v)
+ (close-input-port xmpp-in-port-v))
+
) ;; end module
+
Please sign in to comment.
Something went wrong with that request. Please try again.