From 0720747d47d24158a1907b41d5692f40baa0932d Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Sat, 28 Mar 2009 11:47:22 +0100 Subject: [PATCH] first pass at XMPP for communication --- comm/README | 24 ++++ comm/examples.scm | 23 ++++ comm/xmpp.scm | 290 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 337 insertions(+) create mode 100644 comm/README create mode 100644 comm/examples.scm create mode 100644 comm/xmpp.scm diff --git a/comm/README b/comm/README new file mode 100644 index 0000000..e212c1b --- /dev/null +++ b/comm/README @@ -0,0 +1,24 @@ + +Various parts of the groworld multplayer communcation infrastructure +preliminary notes can be found online at -> +http://lib.fo.am/groworld_multiplayer_prototype#network_protocol + +;; exmaple chat client + +(require "xmpp.scm") + +(define (read-input prompt) + (display prompt) + (read-line (current-input-port))) + +(define (chat) + (let ((jid (read-input "jid: ")) + (pass (read-input "password: ")) + (to (read-input "chat with: "))) + (with-xmpp-session jid pass + (set-xmpp-handler 'message print-message) + (let loop () + (let ((msg (read-line (current-input-port)))) + (send (message to msg)) + (loop)))))) + diff --git a/comm/examples.scm b/comm/examples.scm new file mode 100644 index 0000000..d968333 --- /dev/null +++ b/comm/examples.scm @@ -0,0 +1,23 @@ +#lang scheme + +;; exmaple chat client + +(require "xmpp.scm") + +(define (read-input prompt) + (display prompt) + (read-line (current-input-port))) + +(define (chat) + (let ((jid (read-input "jid: ")) + (pass (read-input "password: ")) + (to (read-input "chat with: "))) + (with-xmpp-session jid pass + (set-xmpp-handler 'message print-message) + (let loop () + (let ((msg (read-line (current-input-port)))) + (send (message to msg)) + (loop)))))) + + + diff --git a/comm/xmpp.scm b/comm/xmpp.scm new file mode 100644 index 0000000..9c7b70c --- /dev/null +++ b/comm/xmpp.scm @@ -0,0 +1,290 @@ +;;; A basic XMPP library which should conform to RFCs 3920 and 3921 +;;; +;;; Copyright (C) 2009 FoAM vzw. LGPL. +;;; +;;; Authors +;;; +;;; nik gaffney +;;; +;;; Requirements +;;; +;;; PLT for now. +;;; +;;; Commentary +;;; +;;; Still a long way from implementing even a minimal subset of XMPP +;;; +;;; features implemented +;;; - establish plaintext connections on port 5222 +;;; - partial "old sytle" ssl connections on port 5223 +;;; - 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 subscription (rfc 3921 sec.6) +;;; - rosters (rfc 3921 sec.7) +;;; - plaintext/ssl/tls 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 +;;; - read-async & repsonse-handler +;;; - ssax:xml->sxml or lazy:xml->sxml +;;; - default handlers +;;; - ssl read/write sequence +;;; - chatbot exmples +;;; + +(module xmpp scheme + + (provide (all-defined-out) + ;open-connection + ;open-ssl-connection + ;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) + + ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; + ;; + ;; networking + ;; + ;;;;;; ;; ;; ; ; ; ; + + (define port 5222) + (define ssl-port 5223) + + (define ssl-write-flag #t) ;; semaphore for half-duplex ssl + + (define (ssl-write b) + (set! ssl-write-flag b)) + + (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) + (define bstr (make-bytes 0 0)) + (when (byte-ready? in) + (if (eq? (peek-byte in) eof) + (break-thread (current-thread)) + (begin + (set! bstr (bytes-append bstr + (make-bytes 1 (read-byte in)) + (read-async in)))))) bstr) + + (define ssxml srl:sxml->xml-noindent) + + ;;;;;; ; ; ; ; ;; ;;;;;; ; + ;; + ;; XMPP stanzas + ;; + ;;;;;;;;;; ;;; ; ;; ; ; + + ;; intialization + (define (xmpp-stream host) + (string-append "")) + + ;; 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")))))) + + (define (starttls) "") + + ;; 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))))))) + + + ;; 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()")) + + + ;;;;;;;;; ; ;; ; ; ;; ;; ; ; + ;; + ;; 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 (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) + (newline) + (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 'unknown 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 "")))) + + ;; repsonse handler + (define (xmpp-response-handler in) + (thread (lambda () + (let loop () + (when ssl-write-flag + (parse-xmpp-response (bytes->string/utf-8 (read-async in)))) + (sleep 0.1) + (loop))))) + + ;; ideally something like this would work.. . + (define (xmmp-read-stanza in) + (parse-xmpp-response (read-line in))) + + ;; 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 + ;; + ;;;;; ;; ;;;; ; ;; ; + + (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))) + (define (send str) (fprintf out "~A~%" str)) + (file-stream-buffer-mode out 'line) + (xmpp-response-handler in) + (send (xmpp-stream host)) + (send (xmpp-session host)) + ;(send starttls) + (send (xmpp-auth user ,pass resource)) + (send (presence)) + (send (presence #:status "Available")) + ,@body + (close-output-port out) + (close-input-port in)))) + + +) ;; end module +