;;; A basic XMPP library which should conform to RFCs 3920 and 3921 ;;; ;;; Copyright (C) 2009 FoAM vzw. ;;; ;;; This package is free software: you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation, either ;;; version 3 of the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You can find a copy of the GNU Lesser General Public License at ;;; http://www.gnu.org/licenses/lgpl-3.0.html. ;;; ;;; Authors ;;; ;;; nik gaffney ;;; ;;; Requirements ;;; ;;; PLT for now. TLS requires a version of PLT > 4.1.5.3 ;;; ;;; Commentary ;;; ;;; 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 (default) ;;; - authenticate using an existing account ;;; - send messages (rfc 3921 sec.4) ;;; - 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 & 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 ;;; - message types ;;; - maintain session ids ;;; - maintain threads ;;; - error handling ;;; - events ;;; - [...] ;;; - rfc 3920 ;;; - rfc 3921 ;;; ;;; bugs and/or improvements ;;; - 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 ;;; - default handlers ;;; - syntax for defining sxpath based handlers ;;; - improve parsing ;;; - chatbot exmples ;;; (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? #f) (define debugf (case-lambda ((str) (when debug? (printf str))) ((str . dir) (when debug? (apply printf (cons str dir)))))) ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; ;; ;; networking ;; ;;;;;; ;; ;; ; ; ; ; (define port 5222) (define ssl-port 5223) (define (open-connection machine port handler) (let-values (((in out) (tcp-connect machine port))) (handler in out) (close-output-port out) (close-input-port in))) (define (open-ssl-connection machine port handler) (let-values (((in out) (ssl-connect machine port 'tls))) (handler in out) (close-output-port out) (close-input-port in))) (define (read-async in) (bytes->string/utf-8 (list->bytes (read-async-bytes in)))) (define (read-async-bytes in) (let ((bstr '())) (when (sync/timeout 0 in) (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr)) (define ssxml srl:sxml->xml-noindent) ;;;;;; ; ; ; ; ;; ;;;;;; ; ;; ;; XMPP stanzas ;; ;;;;;;;;;; ;;; ; ;; ; ; ;; intialization (define (xmpp-stream host) (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) (ssxml `(iq (@ (type "set") (id "auth")) (query (@ (xmlns "jabber:iq:auth")) (username ,username) (password ,password) (resource ,resource))))) (define (xmpp-session host) (ssxml `(iq (@ (to ,host) (type "set") (id "session")) (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))) ;; messages (define (message to body) (ssxml `(message (@ (to ,to)) (body ,body)))) ;; presence (define (presence #:from (from "") #:to (to "") #:type (type "") #:show (show "") #:status (status "")) (cond ((not (string=? status "")) (ssxml `(presence (@ (type "probe")) (status ,status)))) ((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 (ns "")) stanza) (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza))) (if (empty? node) "" (car node)))) ;; message (define message-from (sxpath-element "message/@from/text()")) (define message-to (sxpath-element "message/@to/text()")) (define message-id (sxpath-element "message/@id/text()")) (define message-type (sxpath-element "message/@type/text()")) (define message-body (sxpath-element "message/body/text()")) (define message-subject (sxpath-element "message/subject/text()")) ;; info/query (define iq-type (sxpath-element "iq/@type/text()")) (define iq-id (sxpath-element "iq/@id/text()")) (define iq-error-type (sxpath-element "iq/error/@type/text()")) (define iq-error-text (sxpath-element "iq/error/text()")) (define iq-error (sxpath-element "iq/error")) ;; presence (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")))))) ;;;; ;; ; ;;; ; ;; ;; 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' ;;;;;;;;; ; ;; ; ; ;; ;; ; ; ;; ;; parsing & message/iq/error handlers ;; - minimal parsing ;; - handlers match on a tag (eg. 'message) ;; - handlers are called with a single relevant xmpp stanza ;; ;;;;;; ;; ; ; ;; ; (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)) (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 (debugf "attempting to run handler ~a.~%" fcn) (fcn sz))))) ;; no real parsing yet. dispatches any received xml stanzas as sxml (define (parse-xmpp-response str) (when (> (string-length str) 0) (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '()))) ;;(let ((sz (lazy:xml->sxml (open-input-string str) '()))) (cond ((equal? '(null) (cadr sz)) (newline)) ((equal? 'message (caadr sz)) (run-xmpp-handler 'message sz)) ((equal? 'iq (caadr sz)) (run-xmpp-handler 'iq sz)) ((equal? 'presence (caadr sz)) (run-xmpp-handler 'presence sz)) (else (run-xmpp-handler 'other sz)))))) ;; example handlers to print stanzas or their contents (define (print-message sz) (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz))) (define (print-iq sz) (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz))) (define (print-presence sz) (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status))) (define (print-stanza 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) (let ((test (substring str 0 3))) (cond ((string-ci=? test "~%~%" str) "")))) ;; response handler (define (xmpp-response-handler in) (thread (lambda () (let loop () (parse-xmpp-response (read-async in)) ;(printf "hello~n") (sleep 0.1) ;; slight delay to avoid a tight loop (loop))))) ;; jid splicing (assuming the jid is in the format user@host/resource) (define (jid-user jid) (string-take jid (string-index jid #\@))) (define (jid-host jid) (let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1))) (v (string-index s #\/))) (if v (string-take s v) s ))) (define (jid-resource jid) (let ((r (jid-resource-0 jid))) (if (void? r) (gethostname) r))) (define (jid-resource-0 jid) (let ((v (string-index jid #\/))) (when v (string-take-right jid (- (string-length jid) v 1))))) ;;;; ;; ; ; ;; ;; ;;;; ; ;; ;; interfaces ;; ;;;;; ;; ;;;; ; ;; ; (define xmpp-in-port (make-parameter #f)) (define xmpp-out-port (make-parameter #F)) (define (send str) (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) (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))) (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)) (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