groworld/plant-eyes/jabberer.ss
2009-07-13 12:39:34 +01:00

64 lines
2.1 KiB
Scheme

#lang scheme/base
(require scheme/class fluxus-016/drflux openssl (prefix-in xmpp: "xmpp.ss"))
(provide (all-defined-out))
; a class which wraps the xmpp in a thread and allows messages to be picked up
; and sent by the game
(define debug-netloop #f)
(define jabberer%
(class object%
(init-field
(jid "none@nowhere")
(pass "xxxx"))
(field
(incoming '())
(outgoing '())
(thr 0)
(debug-jab #f))
(define/public (get-incoming)
incoming)
(define/public (clear-incoming)
(set! incoming '()))
(define/public (msg-waiting?)
(not (null? incoming)))
(define/public (get-msg)
(let ((msg (car incoming)))
(set! incoming (cdr incoming))
msg))
(define/public (send-msg to msg)
(set! outgoing (cons (list to msg) outgoing)))
(define (message-handler sz)
(when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz)))
(set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming)))
(define/public (start)
(set! thr (thread run)))
(define/public (stop)
(kill-thread thr))
(define (run)
(xmpp:with-xmpp-session jid pass
(xmpp:set-xmpp-handler 'message message-handler)
(let loop ()
(when debug-netloop (printf ".~n"))
(when (not (null? outgoing))
(for-each
(lambda (msg)
(when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
(xmpp:send (xmpp:message (car msg) (cadr msg))))
outgoing)
(set! outgoing '()))
(sleep 0.5)
(loop))))
(super-new)))