423 lines
14 KiB
Scheme
423 lines
14 KiB
Scheme
;;; 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 <nik@fo.am>
|
|
;;;
|
|
;;; 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? #t)
|
|
|
|
(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 "<?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)
|
|
(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 "") "<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 (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 "<me") str)
|
|
((string-ci=? test "<iq") str)
|
|
((string-ci=? test "<pr") str)
|
|
((string-ci=? test "<ur") str)
|
|
(else
|
|
(debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
|
|
"<null/>"))))
|
|
|
|
|
|
;; response handler
|
|
(define (xmpp-response-handler in)
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(parse-xmpp-response (read-async in))
|
|
(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
|
|
|