From cb3809407aa294b3bfd984b17bbb628584f32cf8 Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Thu, 16 Apr 2009 15:38:52 +0200 Subject: [PATCH] XMPP update --- comm/{xmpp.scm => xmpp.ss} | 98 ++++++++++++++++++++++++++------------ 1 file changed, 67 insertions(+), 31 deletions(-) rename comm/{xmpp.scm => xmpp.ss} (77%) diff --git a/comm/xmpp.scm b/comm/xmpp.ss similarity index 77% rename from comm/xmpp.scm rename to comm/xmpp.ss index abe6bfa..9a3110e 100644 --- a/comm/xmpp.scm +++ b/comm/xmpp.ss @@ -28,8 +28,8 @@ ;;; Still a long way from implementing even a minimal subset of XMPP ;;; ;;; features implemented -;;; - plaintext sessions on port 5222 -;;; - "old sytle" ssl sessions on port 5223 +;;; - plaintext sessions on port 5222 +;;; - "old sytle" ssl sessions on port 5223 (default) ;;; - authenticate using an existing account ;;; - send messages (rfc 3921 sec.4) ;;; - send presence (rfc 3921 sec.5) @@ -53,11 +53,16 @@ ;;; - rfc 3921 ;;; ;;; bugs and/or improvements +;;; - PLaneT installable +;;; - 'send' using call/cc vs 'parameter' i/o ports +;;; - coroutines for sasl negotiation ;;; - read-async & repsonse-handler ;;; - ssax:xml->sxml or lazy:xml->sxml ;;; - default handlers +;;; - syntax for defining sxpath based handlers +;;; - improve parsing ;;; - chatbot exmples -;;; +;;; (module xmpp scheme @@ -67,13 +72,14 @@ ;with-xmpp-session ) - (require (planet lizorkin/sxml:2:1/sxml)) - (require (planet lizorkin/ssax:2:0/ssax)) - (require mzlib/os) - (require mzlib/defmacro) - (require scheme/tcp) - (require openssl) - (require srfi/13) + (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml + (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml + (require mzlib/os) ;; hostname + (require mzlib/defmacro) ;; with-xmpp-session macro + (require scheme/tcp) ;; networking + (require openssl) ;; ssl/tls + (require srfi/13) ;; jid decoding + (require net/base64) ;; sasl ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; ;; @@ -116,7 +122,7 @@ ;; intialization (define (xmpp-stream host) - (string-append "")) + (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) @@ -130,14 +136,12 @@ (ssxml `(iq (@ (to ,host) (type "set") (id "session")) (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))) - (define (starttls) "") - ;; messages (define (message to body) (ssxml `(message (@ (to ,to)) (body ,body)))) ;; presence - (define (presence #:from (from "") + (define (presence #:from (from "") #:to (to "") #:type (type "") #:show (show "") @@ -147,6 +151,13 @@ ((string=? type "") "") (else (ssxml `(presence (@ (type ,type))))))) + ;; queries + (define (iq body + #:from (from "") + #:to (to "") + #:type (type "") + #:id (id "")) + (ssxml `(iq (@ (to ,to) (type ,type) ,body)))) ;; curried stanza disection (sxml stanza -> string) (define ((sxpath-element xpath) stanza) @@ -173,6 +184,18 @@ (define presence-from (sxpath-element "presence/@from/text()")) (define presence-status (sxpath-element "presence/status/text()")) + ;;;; ;; ; ;;; ; + ;; + ;; tls & sasl + ;; - http://xmpp.org/rfcs/rfc3920.html#tls + ;; - http://xmpp.org/rfcs/rfc3920.html#sasl + ;; + ;;;; ;; + + (define session->tls? #f) ;; changes state when a tls proceed is recived + + ;; moved to xmpp-sasl until it 'works' + ;;;;;;;;; ; ;; ; ; ;; ;; ; ; ;; @@ -188,6 +211,9 @@ (define (set-xmpp-handler type fcn) (dict-set! xmpp-handlers type fcn)) + (define (remove-xmpp-handler type fcn) + (dict-remove! xmpp-handlers type fcn)) + (define (run-xmpp-handler type sz) (let ((fcn (dict-ref xmpp-handlers type #f))) (when fcn (begin @@ -209,7 +235,7 @@ (run-xmpp-handler 'iq sz)) ((equal? 'presence (caadr sz)) (run-xmpp-handler 'presence sz)) - (else (run-xmpp-handler 'unknown sz)))))) + (else (run-xmpp-handler 'other sz)))))) ;; example handlers to print stanzas or their contents (define (print-message sz) @@ -230,7 +256,10 @@ (cond ((string-ci=? test "")))) + ((string-ci=? test "~%~%" str)) + "")))) ;; response handler @@ -257,7 +286,7 @@ (define (jid-resource-0 jid) (let ((v (string-index jid #\/))) (when v (string-take-right jid (- (string-length jid) v 1))))) - + ;;;; ;; ; ; ;; ;; ;;;; ; ;; @@ -265,6 +294,13 @@ ;; ;;;;; ;; ;;;; ; ;; ; + (define xmpp-in-port (make-parameter (current-input-port))) + (define xmpp-out-port (make-parameter (current-output-port))) + + (define (send str) + (printf "sending iO: ~a ~%~%" str) + (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port))) + (defmacro with-xmpp-session (jid pass . body) `(let ((host (jid-host ,jid)) (user (jid-user ,jid)) @@ -272,19 +308,19 @@ (let-values (((in out) (ssl-connect host ssl-port 'tls))) ;;(tcp-connect host port))) - (define (send str) (fprintf out "~A~%" str) (flush-output out)) - (file-stream-buffer-mode out 'line) - (xmpp-response-handler in) - (send (xmpp-stream host)) - (send (xmpp-session host)) - ;(send starttls) - (send (xmpp-auth user ,pass resource)) - (send (presence)) - (send (presence #:status "Available")) - ,@body - (close-output-port out) - (close-input-port in)))) - + (parameterize ((xmpp-in-port in) + (xmpp-out-port 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)) + (send (presence #:status "Available")) + ,@body + (close-output-port out) + (close-input-port in))))) ) ;; end module -