XMPP update

This commit is contained in:
nik gaffney 2009-04-16 15:38:52 +02:00
parent 96452fe2fa
commit cb3809407a

View file

@ -29,7 +29,7 @@
;;; ;;;
;;; features implemented ;;; features implemented
;;; - plaintext sessions on port 5222 ;;; - plaintext sessions on port 5222
;;; - "old sytle" ssl sessions on port 5223 ;;; - "old sytle" ssl sessions on port 5223 (default)
;;; - authenticate using an existing account ;;; - authenticate using an existing account
;;; - send messages (rfc 3921 sec.4) ;;; - send messages (rfc 3921 sec.4)
;;; - send presence (rfc 3921 sec.5) ;;; - send presence (rfc 3921 sec.5)
@ -53,9 +53,14 @@
;;; - rfc 3921 ;;; - rfc 3921
;;; ;;;
;;; bugs and/or improvements ;;; bugs and/or improvements
;;; - PLaneT installable
;;; - 'send' using call/cc vs 'parameter' i/o ports
;;; - coroutines for sasl negotiation
;;; - read-async & repsonse-handler ;;; - read-async & repsonse-handler
;;; - ssax:xml->sxml or lazy:xml->sxml ;;; - ssax:xml->sxml or lazy:xml->sxml
;;; - default handlers ;;; - default handlers
;;; - syntax for defining sxpath based handlers
;;; - improve parsing
;;; - chatbot exmples ;;; - chatbot exmples
;;; ;;;
@ -67,13 +72,14 @@
;with-xmpp-session ;with-xmpp-session
) )
(require (planet lizorkin/sxml:2:1/sxml)) (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
(require (planet lizorkin/ssax:2:0/ssax)) (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
(require mzlib/os) (require mzlib/os) ;; hostname
(require mzlib/defmacro) (require mzlib/defmacro) ;; with-xmpp-session macro
(require scheme/tcp) (require scheme/tcp) ;; networking
(require openssl) (require openssl) ;; ssl/tls
(require srfi/13) (require srfi/13) ;; jid decoding
(require net/base64) ;; sasl
;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
;; ;;
@ -116,7 +122,7 @@
;; intialization ;; intialization
(define (xmpp-stream host) (define (xmpp-stream host)
(string-append "<?xml version='1.0'?><stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='" host "' xmlns='jabber:client'>")) (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
;; authentication ;; authentication
(define (xmpp-auth username password resource) (define (xmpp-auth username password resource)
@ -130,8 +136,6 @@
(ssxml `(iq (@ (to ,host) (type "set") (id "session")) (ssxml `(iq (@ (to ,host) (type "set") (id "session"))
(session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))) (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session"))))))
(define (starttls) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")
;; messages ;; messages
(define (message to body) (define (message to body)
(ssxml `(message (@ (to ,to)) (body ,body)))) (ssxml `(message (@ (to ,to)) (body ,body))))
@ -147,6 +151,13 @@
((string=? type "") "<presence/>") ((string=? type "") "<presence/>")
(else (ssxml `(presence (@ (type ,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) ;; curried stanza disection (sxml stanza -> string)
(define ((sxpath-element xpath) stanza) (define ((sxpath-element xpath) stanza)
@ -173,6 +184,18 @@
(define presence-from (sxpath-element "presence/@from/text()")) (define presence-from (sxpath-element "presence/@from/text()"))
(define presence-status (sxpath-element "presence/status/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) (define (set-xmpp-handler type fcn)
(dict-set! xmpp-handlers 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) (define (run-xmpp-handler type sz)
(let ((fcn (dict-ref xmpp-handlers type #f))) (let ((fcn (dict-ref xmpp-handlers type #f)))
(when fcn (begin (when fcn (begin
@ -209,7 +235,7 @@
(run-xmpp-handler 'iq sz)) (run-xmpp-handler 'iq sz))
((equal? 'presence (caadr sz)) ((equal? 'presence (caadr sz))
(run-xmpp-handler 'presence 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 ;; example handlers to print stanzas or their contents
(define (print-message sz) (define (print-message sz)
@ -230,7 +256,10 @@
(cond ((string-ci=? test "<me") str) (cond ((string-ci=? test "<me") str)
((string-ci=? test "<iq") str) ((string-ci=? test "<iq") str)
((string-ci=? test "<pr") str) ((string-ci=? test "<pr") str)
(else "<null/>")))) ((string-ci=? test "<ur") str)
(else
(display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
"<null/>"))))
;; response handler ;; response handler
@ -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) (defmacro with-xmpp-session (jid pass . body)
`(let ((host (jid-host ,jid)) `(let ((host (jid-host ,jid))
(user (jid-user ,jid)) (user (jid-user ,jid))
@ -272,19 +308,19 @@
(let-values (((in out) (let-values (((in out)
(ssl-connect host ssl-port 'tls))) (ssl-connect host ssl-port 'tls)))
;;(tcp-connect host port))) ;;(tcp-connect host port)))
(define (send str) (fprintf out "~A~%" str) (flush-output out)) (parameterize ((xmpp-in-port in)
(xmpp-out-port out))
(file-stream-buffer-mode out 'line) (file-stream-buffer-mode out 'line)
(xmpp-response-handler in) (xmpp-response-handler in)
(send (xmpp-stream host)) (send (xmpp-stream host))
(send (xmpp-session host)) (send (xmpp-session host))
;(send starttls) ;(starttls in out)
(send (xmpp-auth user ,pass resource)) (send (xmpp-auth user ,pass resource))
(send (presence)) (send (presence))
(send (presence #:status "Available")) (send (presence #:status "Available"))
,@body ,@body
(close-output-port out) (close-output-port out)
(close-input-port in)))) (close-input-port in)))))
) ;; end module ) ;; end module