diff --git a/comm/README b/comm/README index e212c1b..bddffb7 100644 --- a/comm/README +++ b/comm/README @@ -1,24 +1,19 @@ 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 +The XMPP module is installable via planet, which should provide a more +stable version. please use (require (planet zzkt/xmpp)) rather than +the older version of xmpp.ss that was included here. + + + + + + -(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.ss b/comm/xmpp.ss deleted file mode 100644 index cc453d3..0000000 --- a/comm/xmpp.ss +++ /dev/null @@ -1,326 +0,0 @@ -;;; 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 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 (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) - (send (xmpp-stream host)) - (send (xmpp-session host)) - ;(starttls in out) - - (send (xmpp-auth user ,pass resource)) - (send (presence)) - (send (presence #:status "Available")) - ,@body - (close-output-port out) - (close-input-port in))))) - - ) ;; end module