56 lines
1.6 KiB
Scheme
56 lines
1.6 KiB
Scheme
|
#lang scheme
|
||
|
|
|
||
|
|
(require "xmpp-dave.ss")
|
||
|
|
(require scheme/class)
|
||
|
|
(require openssl)
|
||
|
|
|
||
|
|
(define jabberer%
|
||
|
|
(class object%
|
||
|
|
(field
|
||
|
|
(incoming '())
|
||
|
|
(outgoing '())
|
||
|
|
(thr 0)
|
||
|
|
(jid "")
|
||
|
|
(pass ""))
|
||
|
|
|
||
|
|
(define/public (get-incoming)
|
||
|
|
incoming)
|
||
|
|
|
||
|
|
(define/public (clear-incoming)
|
||
|
|
(set! incoming '()))
|
||
|
|
|
||
|
|
(define/public (send-msg to msg)
|
||
|
|
(set! outgoing (cons (list to msg) outgoing)))
|
||
|
|
|
||
|
|
(define (message-handler sz)
|
||
|
|
(printf "<---- ~a ~a~n" (message-from sz) (message-body sz))
|
||
|
|
(set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
|
||
|
|
|
||
|
|
(define/public (start j p)
|
||
|
|
(set! jid j)
|
||
|
|
(set! pass p)
|
||
|
|
(set! thr (thread run)))
|
||
|
|
|
||
|
|
(define/public (stop)
|
||
|
|
(kill-thread thr))
|
||
|
|
|
||
|
|
(define (run)
|
||
|
|
(with-xmpp-session jid pass
|
||
|
|
(set-xmpp-handler 'message message-handler)
|
||
|
|
(let loop ()
|
||
|
|
(when (not (null? outgoing))
|
||
|
|
(for-each
|
||
|
|
(lambda (msg)
|
||
|
|
(printf "----> ~a ~a~n" (car msg) (cadr msg))
|
||
|
|
(xmpp-send (message (car msg) (cadr msg))))
|
||
|
|
outgoing)
|
||
|
|
(set! outgoing '()))
|
||
|
|
(sleep 0.5)
|
||
|
|
(loop))))
|
||
|
|
(super-new)))
|
||
|
|
|
||
|
|
(define j (make-object jabberer%))
|
||
|
|
|
||
|
|
(send j start "plant0000001@fo.am" "plant0000001")
|
||
|
|
(send j send-msg "dave@fo.am" "woop")
|