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

still no SASL

Browse source
This commit is contained in:
nik gaffney 2009-04-16 15:18:01 +02:00
parent a369064269
commit 5577f23694
2 changed files with 95 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
README.md
View file

@ -13,6 +13,34 @@ currently documented in the file 'xmpp.ss'
(require (planet zzkt/xmpp:1:0/xmpp))
## Session
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.
## Sending
Once a session is established, the 'send' function can be used to send
messages, presnece updates or queries.
(with-xmpp-session jid pass
(send (message user@host "some random message")))
Where 'jid' is the senders jid and 'pass' is the password
## Response Handlers
A handler can be registered to repsond to 'message 'presence 'iq or
'other stanzas. Note that an 'iq handler will revive any error
messages from the server
(set-xmpp-handler 'message print-message)
## Example Chat Client
(require xmpp)

70
xmpp.ss
View file

@ -29,7 +29,7 @@
;;;
;;; features implemented
;;; - 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
;;; - send messages (rfc 3921 sec.4)
;;; - send presence (rfc 3921 sec.5)
@ -54,9 +54,13 @@
;;;
;;; 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
;;;
@ -68,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
;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
;;
@ -117,7 +122,7 @@
;; 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'>"))
(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
(define (xmpp-auth username password resource)
@ -131,8 +136,6 @@
(ssxml `(iq (@ (to ,host) (type "set") (id "session"))
(session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session"))))))
(define (starttls) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")
;; messages
(define (message to body)
(ssxml `(message (@ (to ,to)) (body ,body))))
@ -148,6 +151,13 @@
((string=? type "") "<presence/>")
(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)
@ -174,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'
;;;;;;;;; ; ;; ; ; ;; ;; ; ;
;;
@ -189,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
@ -210,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)
@ -231,7 +256,10 @@
(cond ((string-ci=? test "<me") str)
((string-ci=? test "<iq") 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
@ -266,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))
@ -273,19 +308,20 @@
(let-values (((in out)
(ssl-connect host ssl-port 'tls)))
;;(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)
(xmpp-response-handler in)
(send (xmpp-stream host))
(send (xmpp-session host))
;(send starttls)
;(starttls in out)
(send (xmpp-auth user ,pass resource))
(send (presence))
(send (presence #:status "Available"))
,@body
(close-output-port out)
(close-input-port in))))
(close-input-port in)))))
) ;; end module