initial support for rosters

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[

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)
+;;;   - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
-;;;   - rosters (rfc 3921 sec.7)
+;;;   - 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
+;;;   - start & stop functions for multiple sessions
-;;;   - 'send' using call/cc vs 'parameter' i/o ports
+;;;   - 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) 
+  (define ((sxpath-element xpath (ns "")) stanza) 
-    (let ((node ((sxpath xpath) 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-in-port (make-parameter #f))
-  (define xmpp-out-port (make-parameter (current-output-port)))
+  (define xmpp-out-port (make-parameter #F))
   
   (define (send str)
-    (printf "sending iO: ~a ~%~%" str)
+    (debugf "sending: ~a ~%~%" str)
-    (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
+    (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
+