first pass at XMPP for communication
This commit is contained in:
parent
232554e5af
commit
0720747d47
3 changed files with 337 additions and 0 deletions
24
comm/README
Normal file
24
comm/README
Normal file
|
|
@ -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))))))
|
||||
|
||||
23
comm/examples.scm
Normal file
23
comm/examples.scm
Normal file
|
|
@ -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))))))
|
||||
|
||||
|
||||
|
||||
290
comm/xmpp.scm
Normal file
290
comm/xmpp.scm
Normal file
|
|
@ -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 <nik@fo.am>
|
||||
;;;
|
||||
;;; 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 "<?xml version='1.0'?><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"))))))
|
||||
|
||||
(define (starttls) "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")
|
||||
|
||||
;; 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)))))))
|
||||
|
||||
|
||||
;; 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 "<me") str)
|
||||
((string-ci=? test "<iq") str)
|
||||
((string-ci=? test "<pr") str)
|
||||
(else "<null/>"))))
|
||||
|
||||
;; 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
|
||||
|
||||
Loading…
Reference in a new issue