1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
(define-module (gnubba xmpp)
#:use-module (sxml simple)
#:use-module ((sxml xpath) #:select (sxpath))
#:use-module ((srfi srfi-1) #:select (find))
#:export (iq iq?
presence presence?
message message?
stanza-id
stanza-to
stanza-from
stanza-type
register-temp-stanza-handler-for-id
register-stanza-handler
run-handler-loop
))
;; TODO: it's ugly to have global variables like this. Can this be
;; scoped inside the loop or with-component/with-connection functions?
(define *stanza-handlers* '())
(define *stanza-id-handlers* (make-hash-table))
(define (register-stanza-handler predicate handler)
"Register handler function that will be executed when a stanza is
encountered that matches the given predicate."
(set! *stanza-handlers* (cons `(,predicate . ,handler) *stanza-handlers*)))
(define (register-temp-stanza-handler-for-id stanza-id handler)
"Register handler function that will be executed when a stanza with
the given id is encountered by the parser. Upon execution the handler
is unregistered."
(hash-set! *stanza-id-handlers* stanza-id
(lambda (stanza)
(begin
(hash-remove! *stanza-id-handlers* stanza-id)
(handler stanza)))))
(define (try-stanza-handlers stanza)
"Run all matching handlers in *stanza-handlers*."
(map (lambda (pair)
(let ((predicate (car pair))
(handler (cdr pair)))
(when (predicate stanza)
(handler stanza))))
*stanza-handlers*))
(define (handle-stanza stanza)
"Check if handler for this stanza id exists and run it if it exists. Then try all other handlers."
(let ((id-handler (hash-ref *stanza-id-handlers* (stanza-id stanza))))
(catch 'halt
(lambda ()
(when id-handler (id-handler stanza))
(try-stanza-handlers stanza))
(lambda (key . args)
;; return whatever argument was passed to 'halt
(car args)))))
(define (run-handler-loop port)
"Repeatedly check for incoming stanzas. When a stanza handler exists it is executed in parallel. A handler may register new handlers."
(catch #t
(lambda ()
(while (not (port-closed? port))
(let ((stanza (xml->sxml port #:trim-whitespace? #t)))
(format #t "received a stanza: ~s\n" stanza)
;; TODO: handle the stanza in a non-blocking manner!
(handle-stanza stanza)
;; no tight loop, please
(sleep 1)))
(display "port was closed.\n"))
(lambda (key . args)
(format #t "ERROR: in handler loop: ~a ~a\n" key args)
key)))
(define next-stanza-id!
(let ((id 0))
(lambda (type)
"Return a new stanza id. Never returns the same id."
(let ((res (format #f "gnubba-~4,'0X-~a" id (symbol->string type))))
(set! id (1+ id))
res))))
(define (drop-empty-attr attributes)
`(@ ,@(filter (lambda (attr)
(not (string-null? (cadr attr))))
(cdr attributes))))
(define* (iq body #:key
(from "")
(to "")
(type "get")
(id (next-stanza-id! 'iq)))
`(*TOP* (iq ,(drop-empty-attr `(@ (from ,from)
(to ,to)
(type ,type)
(id ,id)))
,body)))
(define (message to body)
`(*TOP* (message (@ (to ,to)) (body ,body))))
(define* (presence #:optional body #:key
(from "")
(to "")
(type "")
(id (next-stanza-id! 'pres)))
(let ((attr (drop-empty-attr
`(@ (type ,type)
(from ,from)
(to ,to)
(id ,id)))))
`(*TOP* ,(if body
`(presence ,attr ,body)
`(presence ,attr)))))
(define (stanza-find-property property-name stanza)
"Return the given property of a stanza or #f if there is none."
(let ((properties (cadr stanza)))
(if (equal? '@ (car properties))
(let ((res (find (lambda (prop) (eq? property-name (car prop)))
(cdr properties))))
(if res
(cadr res)
#f)))))
;; generate accessor functions for various stanza attributes
(for-each
(lambda (attr)
(eval `(define ,(symbol-append 'stanza- attr)
(lambda (stanza) (stanza-find-property (quote ,attr) stanza)))
(current-module)))
'(from to type id))
;; TODO: here again with macros:
;; (define-syntax define-attribute
;; (lambda (form)
;; (syntax-case form ()
;; ((define-attribute attr)
;; (identifier? #'attr)
;; (with-syntax
;; ((name (datum->syntax #'attr (symbol-append 'stanza- (syntax->datum #'attr)))))
;; #'(define (name stanza)
;; (stanza-find-property 'attr stanza)))))))
;; (define-syntax-rule (define-attributes (attr ...))
;; (begin (define-attribute attr) ...))
;; (define-attributes (from to type id))
(define (iq? stanza) (not (null? ((sxpath '(iq)) stanza))))
(define (message? stanza) (not (null? ((sxpath '(message)) stanza))))
(define (presence? stanza) (not (null? ((sxpath '(presence)) stanza))))
|
