From a78e99c2aeac076fe49c65d7567f4f2ddbec8920 Mon Sep 17 00:00:00 2001 From: Dave Griffiths Date: Tue, 21 Apr 2009 09:48:33 +0100 Subject: [PATCH] tidied up jabbering --- hayfever/jabberer.scm | 55 +++++++ hayfever/xmpp-dave.ss | 326 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 381 insertions(+) create mode 100644 hayfever/jabberer.scm create mode 100644 hayfever/xmpp-dave.ss diff --git a/hayfever/jabberer.scm b/hayfever/jabberer.scm new file mode 100644 index 0000000..8684e13 --- /dev/null +++ b/hayfever/jabberer.scm @@ -0,0 +1,55 @@ +#lang scheme + +(require "xmpp-dave.ss") +(require scheme/class) +(require openssl) + +(define jabberer% + (class object% + (field + (incoming '()) + (outgoing '()) + (thr 0) + (jid "") + (pass "")) + + (define/public (get-incoming) + incoming) + + (define/public (clear-incoming) + (set! incoming '())) + + (define/public (send-msg to msg) + (set! outgoing (cons (list to msg) outgoing))) + + (define (message-handler sz) + (printf "<---- ~a ~a~n" (message-from sz) (message-body sz)) + (set! incoming (cons (list (message-from sz) (message-body sz)) incoming))) + + (define/public (start j p) + (set! jid j) + (set! pass p) + (set! thr (thread run))) + + (define/public (stop) + (kill-thread thr)) + + (define (run) + (with-xmpp-session jid pass + (set-xmpp-handler 'message message-handler) + (let loop () + (when (not (null? outgoing)) + (for-each + (lambda (msg) + (printf "----> ~a ~a~n" (car msg) (cadr msg)) + (xmpp-send (message (car msg) (cadr msg)))) + outgoing) + (set! outgoing '())) + (sleep 0.5) + (loop)))) + (super-new))) + +(define j (make-object jabberer%)) + +(send j start "plant0000001@fo.am" "plant0000001") +(send j send-msg "dave@fo.am" "woop") diff --git a/hayfever/xmpp-dave.ss b/hayfever/xmpp-dave.ss new file mode 100644 index 0000000..17adcaa --- /dev/null +++ b/hayfever/xmpp-dave.ss @@ -0,0 +1,326 @@ +;;; 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 +;;; +;;; features to implement +;;; - account creation +;;; - managing subscriptions (rfc 3921 sec.6) +;;; - 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 +;;; - 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-dave scheme + + (provide (all-defined-out) + ;open-connection + ;open-ssl-connection + ;with-xmpp-session + ) + + (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 + + ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; + ;; + ;; 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) stanza) + (let ((node ((sxpath xpath) 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()")) + + ;;;; ;; ; ;;; ; + ;; + ;; 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) + + (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 + ;(display (format "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) + (display (format "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))) + + (define (print-iq sz) + (display (format "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))) + + (define (print-presence sz) + (display (format " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))) + + (define (print-stanza sz) + (display (format "? ?? -> ~%~a~%" 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)) + (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 (current-input-port))) + (define xmpp-out-port (make-parameter (current-output-port))) + + (define (xmpp-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)) + (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) + (xmpp-send (xmpp-stream host)) + (xmpp-send (xmpp-session host)) + ;(starttls in out) + + (xmpp-send (xmpp-auth user ,pass resource)) + (xmpp-send (presence)) + (xmpp-send (presence #:status "Available")) + ,@body + (close-output-port out) + (close-input-port in))))) + + ) ;; end module