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
155
156
157
158
159
160
161
|
(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-syntax register-stanza-handler
(lambda (s)
"Register handler function that will be executed when a stanza is
encountered that matches the given predicate."
(syntax-case s ()
((_ guard handler)
(if (eqv? #t (syntax->datum #'guard))
#'(set! *stanza-handlers* (cons `(,(lambda _ #t) . ,handler) *stanza-handlers*))
#'(set! *stanza-handlers* (cons `(,guard . ,handler) *stanza-handlers*))))
((_ handler)
#'(set! *stanza-handlers* (cons `(,(lambda _ #t) . ,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)))
(if (predicate stanza)
(handler stanza)
#f)))
*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) args))))
(define* (run-handler-loop port #:optional (log-port #t))
"Repeatedly check for incoming stanzas. When a stanza handler
exists it is executed in parallel. A handler may register new
handlers."
(while (not (or (port-closed? port)
(eof-object? (peek-char port))))
(catch #t
(lambda _
(let ((stanza (xml->sxml port #:trim-whitespace? #t)))
;; TODO: handle the stanza in a non-blocking manner!
(handle-stanza stanza)
;; no tight loop, please
(sleep 1)))
(lambda (key . args)
(format log-port "ERROR: in handler loop: ~a ~a\n" key args)
key)))
(format log-port "port was closed.\n"))
(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 value of a given stanza property or #f if there is
none."
(let ((property ((sxpath `(* @ ,property-name)) stanza)))
(if (null? property)
#f
(cadar property))))
;; 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))))
|
