2009-07-13 11:39:34 +00:00
|
|
|
#lang scheme/base
|
2009-09-25 16:19:48 +00:00
|
|
|
(require scheme/class); openssl (prefix-in xmpp: "xmpp.ss"))
|
2009-07-13 11:39:34 +00:00
|
|
|
(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
|
|
|
|
|
2009-07-27 08:50:07 +00:00
|
|
|
(define debug-netloop #f)
|
2009-07-13 11:39:34 +00:00
|
|
|
|
|
|
|
(define jabberer%
|
|
|
|
(class object%
|
|
|
|
(init-field
|
|
|
|
(jid "none@nowhere")
|
|
|
|
(pass "xxxx"))
|
|
|
|
|
|
|
|
(field
|
|
|
|
(incoming '())
|
|
|
|
(outgoing '())
|
|
|
|
(thr 0)
|
2009-08-19 13:41:02 +00:00
|
|
|
(debug-jab #f))
|
2009-07-13 11:39:34 +00:00
|
|
|
|
|
|
|
(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)
|
2009-07-30 15:03:21 +00:00
|
|
|
(set! outgoing (append outgoing (list (list to msg)))))
|
2009-07-13 11:39:34 +00:00
|
|
|
|
2009-09-25 16:19:48 +00:00
|
|
|
(define (message-handler sz) 0)
|
|
|
|
; (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)))
|
2009-07-13 11:39:34 +00:00
|
|
|
|
|
|
|
(define/public (start)
|
2009-07-13 15:01:20 +00:00
|
|
|
(set! thr (thread run)))
|
2009-07-13 11:39:34 +00:00
|
|
|
|
|
|
|
(define/public (stop)
|
|
|
|
(kill-thread thr))
|
|
|
|
|
2009-09-25 16:19:48 +00:00
|
|
|
(define (run) 0
|
|
|
|
#;(xmpp:with-xmpp-session jid pass
|
2009-07-13 11:39:34 +00:00
|
|
|
(xmpp:set-xmpp-handler 'message message-handler)
|
|
|
|
(let loop ()
|
|
|
|
(when debug-netloop (printf ".~n"))
|
|
|
|
(when (not (null? outgoing))
|
2009-07-30 15:03:21 +00:00
|
|
|
(when debug-jab (printf "tx ----> ~a ~a~n" (car (car outgoing)) (cadr (car outgoing))))
|
2009-07-22 15:35:15 +00:00
|
|
|
(xmpp:send (xmpp:message (car (car outgoing)) (cadr (car outgoing))))
|
|
|
|
(set! outgoing (cdr outgoing)))
|
2009-07-30 15:03:21 +00:00
|
|
|
(sleep 0.221)
|
2009-07-13 11:39:34 +00:00
|
|
|
(loop))))
|
|
|
|
(super-new)))
|