zzkt/gibberish
1
0
Fork 0
Code Issues 1 Pull requests Packages Projects Releases Wiki Activity

initial support for rosters

Browse source
This commit is contained in:
nik gaffney 2009-05-22 17:26:47 +02:00
parent a84b6dcda1
commit ebde9b3d5e
2 changed files with 142 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
xmpp.scrbl
View file

@ -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[

148
xmpp.ss
View file

@ -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