diff --git a/xmpp.scrbl b/xmpp.scrbl index d38f670..3d0d8f4 100644 --- a/xmpp.scrbl +++ b/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[ diff --git a/xmpp.ss b/xmpp.ss index 841d6f6..7a88bba 100644 --- a/xmpp.ss +++ b/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 "")) ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223 + (string-append "" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223 + "")) ;; 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 "~%~%" str)) + (debugf "~%recieved: ~a ~%parsed as ~%~%" str) "")))) @@ -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 +