Context Navigation

source: project/release/4/dbus/trunk/dbus.scm @ 25905

Last change on this file since 25905 was 25905, checked in by ecloud, 9 years ago
Special case: an empty vector seems to be a vector with a null type inside. Also an untested attempt to append variants.
File size: 30.4 KB

Line
1	;;;; dbus.scm
2
3	(module dbus (make-context
4	send
5	call
6	make-method-proxy
7	register-signal-handler
8	register-method
9	enable-polling-thread!
10	poll-for-message
11	discover-services
12	discover-api-xml
13	dbus-service
14	session-bus
15	system-bus
16	starter-bus
17	known-bus-count
18	register-path
19	unsupported-type?
20	unsupported-type-signature
21	variant?
22	variant-data
23	make-variant
24	auto-unbox-variants)
25	(import scheme chicken extras
26	(except foreign foreign-declare)
27	foreigners
28	easyffi
29	miscmacros)
30	(use srfi-18)
31
32	#>
33	#include <dbus/dbus.h>
34	#include <stdbool.h>
35	#include <stdint.h>
36	#include <fcntl.h>
37	#include <unistd.h>
38
39	static DBusError err;
40	<#
41
42	;; A disjoint type to represent any kind of dbus data type
43	;; which this egg so far does not support. The signature
44	;; is the ASCII string to represent that type on-the-wire.
45	(define-record-type unsupported-type
46	(make-unsupported-type signature)
47	unsupported-type?
48	(signature unsupported-type-signature))
49	(define-record-printer (unsupported-type d out)
50	(fprintf out "#<unsupported-type ~s>" (unsupported-type-signature d)))
51
52	;; Scheme is a dynamically typed language, so fundamentally we don't
53	;; have a use for the "variant" concept; but since dbus has a variant type,
54	;; we need a way of representing one when preparing a message for marshalling.
55	(define-record-type variant
56	(make-variant data)
57	variant?
58	(data variant-data))
59	(define-record-printer (variant v out)
60	(fprintf out "#,(variant ~S)" (variant-data v)))
61	;; If unboxing is turned on, when a "call"ed dbus service method
62	;; returns a variant, it will look as if it was not packaged in a variant at all.
63	;; By default this feature is turned off, in the interest of having a
64	;; representation that is the same as you will need to build when
65	;; you want to send (marshall) a dbus message. But probably
66	;; you want to turn it on for convenience, if you don't care to know
67	;; about this low-level detail.
68	(define auto-unbox-variants (make-parameter #f))
69
70	; Would want to do this:
71	; (define-foreign-enum (bus (enum "DBusBusType"))
72	; (session-bus DBUS_BUS_SESSION)
73	; (system-bus DBUS_BUS_SYSTEM)
74	; (starter-bus DBUS_BUS_STARTER) )
75	; but because that enum is typedef'd, chicken has a problem with it.
76
77	(define-foreign-type bus int) ; really "DBusBusType"
78	(define session-bus (foreign-value DBUS_BUS_SESSION int))
79	(define system-bus (foreign-value DBUS_BUS_SYSTEM int))
80	(define starter-bus (foreign-value DBUS_BUS_STARTER int))
81	(define dbus-service (foreign-value DBUS_SERVICE_DBUS c-string))
82	(define known-bus-count (+ 1 (max session-bus system-bus starter-bus)))
83
84	(define-foreign-type handler-result int) ; really "DBusHandlerResult"
85	(define result-handled (foreign-value DBUS_HANDLER_RESULT_HANDLED int))
86	(define result-not-yet-handled (foreign-value DBUS_HANDLER_RESULT_NOT_YET_HANDLED int))
87	(define result-need-memory (foreign-value DBUS_HANDLER_RESULT_NEED_MEMORY int))
88
89	(define name-flag-allow-replacement (foreign-value DBUS_NAME_FLAG_ALLOW_REPLACEMENT int))
90	(define name-flag-replace-existing (foreign-value DBUS_NAME_FLAG_REPLACE_EXISTING int))
91	(define name-flag-do-not-queue (foreign-value DBUS_NAME_FLAG_DO_NOT_QUEUE int))
92
93	;; DBus simple data types
94	(define type-invalid (foreign-value DBUS_TYPE_INVALID int))
95	(define type-invalid-string (foreign-value DBUS_TYPE_INVALID_AS_STRING int))
96	(define type-byte (foreign-value DBUS_TYPE_BYTE int))
97	(define type-byte-string (foreign-value DBUS_TYPE_BYTE_AS_STRING int))
98	(define type-boolean (foreign-value DBUS_TYPE_BOOLEAN int))
99	(define type-boolean-string (foreign-value DBUS_TYPE_BOOLEAN_AS_STRING int))
100	(define type-int16 (foreign-value DBUS_TYPE_INT16 int))
101	(define type-int16-string (foreign-value DBUS_TYPE_INT16_AS_STRING int))
102	(define type-uint16 (foreign-value DBUS_TYPE_UINT16 int))
103	(define type-uint16-string (foreign-value DBUS_TYPE_UINT16_AS_STRING int))
104	(define type-fixnum (foreign-value DBUS_TYPE_INT32 int))
105	(define type-int32 (foreign-value DBUS_TYPE_INT32 int))
106	(define type-int32-string (foreign-value DBUS_TYPE_INT32_AS_STRING int))
107	(define type-uint32 (foreign-value DBUS_TYPE_UINT32 int))
108	(define type-uint32-string (foreign-value DBUS_TYPE_UINT32_AS_STRING int))
109	(define type-int64 (foreign-value DBUS_TYPE_INT64 int))
110	(define type-int64-string (foreign-value DBUS_TYPE_INT64_AS_STRING int))
111	(define type-uint64 (foreign-value DBUS_TYPE_UINT64 int))
112	(define type-uint64-string (foreign-value DBUS_TYPE_UINT64_AS_STRING int))
113	(define type-double (foreign-value DBUS_TYPE_DOUBLE int))
114	(define type-flonum (foreign-value DBUS_TYPE_DOUBLE int))
115	(define type-double-string (foreign-value DBUS_TYPE_DOUBLE_AS_STRING int))
116	(define type-string (foreign-value DBUS_TYPE_STRING int))
117	(define type-string-string (foreign-value DBUS_TYPE_STRING_AS_STRING int))
118	(define type-object-path (foreign-value DBUS_TYPE_OBJECT_PATH int))
119	(define type-signature (foreign-value DBUS_TYPE_SIGNATURE int))
120	(define type-signature-string (foreign-value DBUS_TYPE_SIGNATURE_AS_STRING int))
121	(define type-array (foreign-value DBUS_TYPE_ARRAY int))
122	(define type-dict (foreign-value DBUS_TYPE_DICT_ENTRY int))
123	(define type-variant (foreign-value DBUS_TYPE_VARIANT int))
124
125	(define make-context)
126	(define send)
127	(define make-method-proxy)
128	(define call)
129	(define flush)
130	(define poll-for-message)
131	(define register-signal-handler)
132	(define register-method)
133	(define register-path)
134	(define enable-polling-thread!)
135
136	(define add-match)
137	(define request-name)
138
139
140	(define find-callback)
141
142	(define-foreign-type error-ptr c-pointer) ;; DBusError*
143	(define-foreign-type connection-ptr c-pointer) ;; DBusConnection*
144	(define-foreign-type message-ptr c-pointer) ;; DBusMessage*
145	(define-foreign-type uint-ptr c-pointer) ;; dbus_uint32_t*
146	(define-foreign-type message-iter-ptr c-pointer) ;; DBusMessageIter*
147	(define-foreign-type vtable-ptr c-pointer) ;; DBusObjectPathVTable*
148
149	(define (discover-services #!key (bus session-bus))
150	(let* ([ctxt (make-context
151	bus: bus
152	service: 'org.freedesktop.DBus
153	interface: 'org.freedesktop.DBus
154	path: '/org/freedesktop/DBus)]
155	[services (call ctxt "ListNames")])
156	(and (pair? services) (vector? (car services)) (vector->list (car services)))))
157
158	(define discover-api-xml)
159
160	(define-external (C_msg_cb (bus bus) (message-ptr msg)) bool
161	(let* ([cb (find-callback bus msg)][found (procedure? cb)])
162	; (printf "got a message: ~s on bus ~a and found callback ~s~%" msg bus cb)
163	(when found
164	(cb msg))
165	found
166	))
167
168	(let ( [connections '()] ;; an alist mapping bus to DBusConnection ptrs
169	[error (foreign-value "&err" c-pointer)]
170	;; indices in a "context" vector
171	[context-idx-ID 0]
172	[context-idx-bus 1]
173	[context-idx-service 2]
174	[context-idx-path 3]
175	[context-idx-interface 4]
176	[context-count 0]
177	[default-polling-interval 0.01]
178	[polling-interval (make-vector known-bus-count 0.01)]
179	[polling-enabled (make-vector known-bus-count #t)]
180	[polling-threads (make-vector known-bus-count #f)]
181	;; will become an assoc tree:
182	;; bus
183	;; path
184	;; service (unless it's a signal callback)
185	;; interface
186	;; method
187	;; callback-fn
188	[callbacks-table `((,system-bus . #f) (,session-bus . #f))]
189	[iterm (gensym 'terminiter)] )
190
191	(define (any->string arg)
192	(if (string? arg)
193	arg
194	(if (eq? (void) arg)
195	""
196	(format "~a" arg))))
197
198	(define (symbol?->string arg)
199	(if (symbol? arg)
200	(symbol->string arg)
201	arg))
202
203	(define (string?->symbol arg)
204	(if (string? arg)
205	(string->symbol arg)
206	arg))
207
208	;; If the assq-list has the given key, replace its value.
209	;; Else add the key-value pair.
210	(define (asset! alist key val)
211	(let ([pr (assq key alist)])
212	(if pr
213	(set-cdr! pr val)
214	(if (null? (cdar alist))
215	(set-car! alist (cons key val))
216	(begin
217	(set-cdr! alist (cons (car alist) (cdr alist)))
218	(set-car! alist (cons key val))) ))))
219
220	;; The "tree" version of assq: drills down into an assq-tree
221	;; as directed by the sequence of keys, and returns the value found.
222	;; #f means not found (so it is not useful to store #f in such a tree).
223	(define (tassq tree . keys)
224	(let ([key-list (if (pair? (car keys)) (car keys) keys)])
225	(let loop ([rem-keys key-list][subtree tree])
226	(if (null? rem-keys)
227	subtree
228	(loop (cdr rem-keys)
229	(let ([pr (assq (car rem-keys) subtree)])
230	(and (pair? pr) (cdr pr))))))))
231
232	;; The "tree" version of asset!: drills down into an assq-tree
233	;; as directed by the sequence of keys, making new branches as necessary,
234	;; and sets the given value as a leaf at that point in the tree.
235	;; return value is undefined
236	(define (tasset! tree val . keys)
237	(let ([key-list (if (pair? (car keys)) (car keys) keys)])
238	(let loop ( [rem-keys (cdr key-list)]
239	[subtree (tassq tree (car key-list))]
240	[prev-key (car key-list)]
241	[prev-subtree tree])
242	; (printf "rem-keys ~s subtree ~s prev-key ~s prev-subtree ~s~%" rem-keys subtree prev-key prev-subtree)
243	(when (and (not subtree) (pair? rem-keys))
244	(set! subtree (list (cons (car rem-keys) #f)))
245	; (printf " creating subtree ~s within ~s~%" subtree prev-subtree)
246	(asset! prev-subtree prev-key subtree)
247	; (pretty-print prev-subtree)
248	)
249	(if (null? rem-keys)
250	(asset! prev-subtree prev-key val)
251	(loop
252	(cdr rem-keys)
253	(let ([pr (assq (car rem-keys) subtree)])
254	(unless (pair? pr)
255	(set! pr (cons (car rem-keys) #f))
256	(set-cdr! subtree (cons (car subtree) (cdr subtree)))
257	(set-car! subtree pr) )
258	(cdr pr))
259	(car rem-keys)
260	subtree )))))
261
262	(define (next-context-ID) (set! context-count (+ 1 context-count)) context-count)
263
264	(define (get-conn bus-type)
265	(let ([conn (assq bus-type connections)])
266	(if (pair? conn)
267	(set! conn (cdr conn))
268	(begin
269	(set! conn ((foreign-lambda connection-ptr "dbus_bus_get" bus error-ptr)
270	bus-type error) )
271	(when conn
272	(set! connections (cons (cons bus-type conn) connections)))))
273	conn))
274
275	(define (conn-or-abort bus-type)
276	(or (get-conn bus-type)
277	(abort (format "unable to connect to bus ~s~%" bus-type))))
278
279	(define (exists-or-abort datum err-str)
280	(or datum
281	(abort err-str)))
282
283	;; params: path interface name
284	;; todo: garbage-collect this
285	(define make-signal (foreign-lambda message-ptr "dbus_message_new_signal"
286	c-string c-string c-string))
287
288	;; params: service path interface method-name
289	;; todo: garbage-collect this
290	(define make-message (foreign-lambda message-ptr "dbus_message_new_method_call"
291	c-string c-string c-string c-string))
292
293	;; todo: garbage-collect this
294	(define make-iter-append
295	(foreign-lambda* message-iter-ptr ((message-ptr msg))
296	"DBusMessageIter* iter = malloc(sizeof(DBusMessageIter));
297	dbus_message_iter_init_append (msg, iter);
298	C_return (iter);"))
299
300	(define iter-append-basic-string
301	(foreign-lambda* bool ((message-iter-ptr iter) (c-string v))
302	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_STRING, &v));"))
303
304	(define iter-append-basic-bool
305	(foreign-lambda* bool ((message-iter-ptr iter) (bool v))
306	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BOOLEAN, &v));"))
307
308	(define iter-append-basic-int
309	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
310	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT32, &v));"))
311
312	(define iter-append-basic-double
313	(foreign-lambda* bool ((message-iter-ptr iter) (double v))
314	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_DOUBLE, &v));"))
315
316	(define iter-append-basic-byte
317	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
318	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BYTE, &v));"))
319
320	(define iter-append-basic-int16
321	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
322	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT16, &v));"))
323
324	(define iter-append-basic-uint32
325	(foreign-lambda* bool ((message-iter-ptr iter) (unsigned-integer32 v))
326	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT32, &v));"))
327
328	(define iter-append-basic-uint16
329	(foreign-lambda* bool ((message-iter-ptr iter) (unsigned-short v))
330	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT16, &v));"))
331
332	(define iter-append-basic-int64
333	(foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
334	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT64, &v));"))
335
336	(define iter-append-basic-uint64
337	(foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
338	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &v));"))
339
340	;; todo efficient
341	(define (char->string ch) (format "~a" ch))
342
343	(define (value-signature val)
344	(cond
345	[(fixnum? val) (char->string type-fixnum)]
346	[(flonum? val) (char->string type-flonum)]
347	[(boolean? val) (char->string type-boolean)]
348	[(variant? val) (value-signature (variant-data val))]
349	; todo: recursive
350	; [(pair? val)
351	))
352
353	(define (iter-append-basic-variant iter val)
354	(let ([signature (value-signature val)])
355	; (let ([append-fn #f][signature ""])
356	; (cond
357	; todo signature should be a string; need to handle complex types nested in variants too
358	; [(fixnum? val)
359	; (set! append-fn iter-append-basic-int)
360	; (set! signature type-fixnum)]
361	; [(flonum? val)
362	; (set! append-fn iter-append-basic-double)
363	; (set! signature type-flonum)]
364	; [(boolean? val)
365	; (set! append-fn iter-append-basic-bool)
366	; (set! signature type-boolean)]
367	; [(variant? val)
368	; (set! append-fn iter-append-basic-variant)
369	; (set! signature type-variant)] )
370	;; todo: for a list, how would I know the composite signature until having done the append?
371	; [(pair? val)
372	; (set! append-fn iter-append-basic)
373	; (set! signature type-variant)] )
374	(let ([container ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter) (c-string signature))
375	"DBusMessageIter value;
376	dbus_message_iter_open_container(iter, DBUS_TYPE_VARIANT, signature, &value);
377	C_return(&value);") iter signature)])
378	(iter-append-basic container val)
379	((foreign-lambda* bool ((message-iter-ptr iter)(message-iter-ptr container))
380	"C_return (dbus_message_iter_close_container(iter, container));") iter container) ) ))
381
382	; (foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
383	; "dbus_message_iter_open_container(iter, DBUS_TYPE_VARIANT, signature, &value);
384	; dbus_message_iter_append_basic(&value, type, val);
385	; C_return (dbus_message_iter_close_container(iter, &value));")
386
387	;; TODO: iter-append-basic-T for each possible type:
388	;; especially variant, array and struct might still be possible
389
390	;; val would usually be a single value, but
391	;; could be a pair of the form (type-x . value)
392	;; in which case we will attempt to convert the value to that type for sending.
393	(define (iter-append-basic iter val)
394	(cond
395	[(fixnum? val) (iter-append-basic-int iter val)]
396	[(flonum? val) (iter-append-basic-double iter val)]
397	[(boolean? val) (iter-append-basic-bool iter val)]
398	[(variant? val) (iter-append-basic-variant iter val)]
399	[(pair? val)
400	(let ([type (car val)])
401	(cond
402	;; TODO: this doesn't compile
403	;; Error: Arguments to inlined call of `iter-append-basic-byte'
404	;; do not match parameter-list (a207 a206)
405	;; so I guess it has to _be_ a byte before the call
406	; [(eq? type type-byte)
407	; (iter-append-basic-byte (cdr val))]
408	; [(eq? type type-int16)
409	; (iter-append-basic-int16 (cdr val))]
410	; [(eq? type type-uint32)
411	; (iter-append-basic-uint32 (cdr val))]
412	; [(eq? type type-uint16)
413	; (iter-append-basic-uint16 (cdr val))]
414	; [(eq? type type-int64)
415	; (iter-append-basic-int64 (cdr val))]
416	; [(eq? type type-uint64)
417	; (iter-append-basic-uint64 (cdr val))]
418	;; other custom requests will be handled as usual, above
419	[else (iter-append-basic iter (cdr val))] ))]
420	[else (iter-append-basic-string iter (any->string val))] ))
421
422	(define free-iter (foreign-lambda* void ((message-iter-ptr i)) "free(i);"))
423
424	(define (iter-cond iter)
425	(let ( [type ((foreign-lambda int "dbus_message_iter_get_arg_type"
426	message-iter-ptr) iter)] )
427	; (printf "iter-cond type ~s~%" type)
428	(cond
429	[(memq type `(,type-string ,type-invalid-string
430	,type-string-string ,type-object-path
431	,type-signature-string
432	;; TODO maybe the following types ought to be converted?
433	,type-byte-string ,type-boolean-string
434	,type-int16-string ,type-uint16-string
435	,type-int32-string ,type-uint32-string
436	,type-int64-string ,type-uint64-string
437	,type-double-string ))
438	((foreign-lambda* c-string ((message-iter-ptr iter))
439	"char* ret;
440	dbus_message_iter_get_basic(iter, &ret);
441	C_return (ret);") iter)]
442	[(eq? type type-boolean)
443	((foreign-lambda* bool ((message-iter-ptr iter))
444	"bool ret;
445	dbus_message_iter_get_basic(iter, &ret);
446	return (ret);") iter)]
447	[(memq type `(,type-int32 ,type-byte
448	,type-int16 ))
449	((foreign-lambda* int ((message-iter-ptr iter))
450	"int ret;
451	dbus_message_iter_get_basic(iter, &ret);
452	C_return (ret);") iter)]
453	[(memq type `(,type-uint32 ,type-uint16))
454	((foreign-lambda* unsigned-int ((message-iter-ptr iter))
455	"unsigned int ret;
456	dbus_message_iter_get_basic(iter, &ret);
457	C_return (ret);") iter)]
458	[(memq type `(,type-flonum ,type-uint64))
459	((foreign-lambda* double ((message-iter-ptr iter))
460	"double ret;
461	dbus_message_iter_get_basic(iter, &ret);
462	C_return (ret);") iter)]
463	[(eq? type type-int64)
464	((foreign-lambda* integer64 ((message-iter-ptr iter))
465	"int64_t ret;
466	dbus_message_iter_get_basic(iter, &ret);
467	C_return (ret);") iter)]
468	[(eq? type type-array)
469	(let ([v (iter->vector (make-sub-iter iter))])
470	(when (and (vector? v) (eq? 1 (vector-length v)) (unsupported-type? (vector-ref v 0)))
471	(set! v (make-vector 0)))
472	v)]
473	[(eq? type type-dict)
474	(iter->pair (make-sub-iter iter))]
475	[(eq? type type-variant)
476	(if (auto-unbox-variants)
477	((make-sub-iter iter))
478	(make-variant ((make-sub-iter iter))))]
479	;; unsupported so far (not understood well enough):
480	;; type-object-path and type-signature
481	;; type-invalid is returned as #f (could be (void) but that
482	;; would be the termination condition for the iterator)
483	[else (make-unsupported-type (integer->char type))] )))
484
485	(define (make-sub-iter iter)
486	(let* ([sub ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter))
487	"DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
488	dbus_message_iter_recurse(iter, i);
489	C_return (i);") iter) ]
490	[has-next sub]
491	)
492	(lambda ()
493	(if has-next
494	(let ([ret (iter-cond sub)])
495	(set! has-next ((foreign-lambda bool
496	"dbus_message_iter_next" message-iter-ptr) sub))
497	ret )
498	(begin
499	(free-iter sub)
500	iterm)
501	))))
502
503	;; iterator for reading parameters from a message
504	;; returns a lambda which provides one param at a time, terminating with (void)
505	(define (make-iter msg)
506	(let* ([iter ((foreign-lambda* message-iter-ptr ((message-ptr msg))
507	"DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
508	if (!dbus_message_iter_init (msg, i))
509	i = (DBusMessageIter*)0; // Message has no parameters
510	C_return (i);") msg) ]
511	[has-next iter]
512	)
513	(lambda ()
514	(if has-next
515	(let ([ret (iter-cond iter)])
516	(set! has-next ((foreign-lambda bool
517	"dbus_message_iter_next" message-iter-ptr) iter))
518	ret )
519	(begin
520	(free-iter iter)
521	iterm)
522	))))
523
524	;; todo maybe: rewrite to avoid the reverse
525	(define (iter->list iter)
526	(let loop ([retval '()])
527	(let ([next (iter)])
528	(if (eq? next iterm)
529	(reverse retval)
530	(loop (cons next retval))))))
531
532	(define (iter->pair iter)
533	(cons (iter) (iter)))
534
535	(define (iter->vector iter)
536	(let ([l (iter->list iter)])
537	(list->vector l)))
538
539	(define msg-path
540	(foreign-lambda c-string "dbus_message_get_path" message-ptr))
541
542	(define msg-interface
543	(foreign-lambda c-string "dbus_message_get_interface" message-ptr))
544
545	(define msg-member
546	(foreign-lambda c-string "dbus_message_get_member" message-ptr))
547
548	(define msg-error-name
549	(foreign-lambda c-string "dbus_message_get_error_name" message-ptr))
550
551	(define msg-service
552	(foreign-lambda c-string "dbus_message_get_destination" message-ptr))
553
554	(set! find-callback (lambda (bus msg)
555	(let ([path (string?->symbol (msg-path msg))]
556	[iface (string?->symbol (msg-interface msg))]
557	[mber (string?->symbol (msg-member msg))]
558	[svc (string?->symbol (msg-service msg))]
559	)
560	; (printf " svc ~s~%" svc)
561	; (printf " path ~s~%" path)
562	; (printf " iface ~s~%" iface)
563	; (printf " mber ~s~%" mber)
564	;; The service name is not included as part of the signal, so svc will be #f.
565	;; In that case the callback is registered under bus/path/iface/signal-name.
566	(if svc
567	(tassq callbacks-table bus path svc iface mber)
568	(tassq callbacks-table bus path iface mber) ))))
569
570	(set! make-context (lambda (#!key (bus session-bus) service interface (path "/"))
571	(vector (next-context-ID) bus (string?->symbol service)
572	(string?->symbol path) (string?->symbol interface)) ))
573
574	(define send-impl
575	(foreign-lambda int "dbus_connection_send" connection-ptr message-ptr uint-ptr))
576
577	(set! send (lambda (context name . params)
578	(let* ( [service (symbol?->string (vector-ref context context-idx-service))]
579	[msg (make-signal
580	(symbol?->string (vector-ref context context-idx-path))
581	(symbol?->string (vector-ref context context-idx-interface))
582	name)]
583	[iter (make-iter-append msg)] )
584	(let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
585	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
586	(for-each (lambda (parm)
587	(iter-append-basic iter parm)) params)
588	(send-impl conn msg #f)
589	(free-iter iter)
590	; ((foreign-lambda void "dbus_connection_flush" connection-ptr) conn)
591	))))
592
593	(set! call (lambda (context name . params)
594	(let* ( [service (symbol->string (vector-ref context context-idx-service))]
595	[msg (make-message service
596	(symbol->string (vector-ref context context-idx-path))
597	(symbol->string (vector-ref context context-idx-interface))
598	name)]
599	[iter (make-iter-append msg)] )
600	(let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
601	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
602	(for-each (lambda (parm)
603	(iter-append-basic iter parm)) params)
604	(free-iter iter)
605	(let* ( [reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
606	;; idealistic code here; todo: error checking
607	;; todo: timeout comes from where? (make-parameter) maybe
608	"DBusMessage *reply;
609	DBusError error;
610	dbus_error_init (&error);
611	reply = dbus_connection_send_with_reply_and_block(conn, msg, 5000, &error);
612	if (dbus_error_is_set (&error))
613	fprintf (stderr, \"Error %s: %s\\n\", error.name, error.message);
614	dbus_message_unref(msg);
615	C_return(reply);") conn msg) ]
616	[reply-iter (make-iter reply-msg)]
617	[reply-args (iter->list reply-iter)] )
618	reply-args)))))
619
620	(set! make-method-proxy (lambda (context name)
621	(let ( [service (symbol->string (vector-ref context context-idx-service))]
622	[conn (conn-or-abort (vector-ref context context-idx-bus))] )
623	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
624	(lambda params
625	(let* ( [msg (make-message service
626	(symbol->string (vector-ref context context-idx-path))
627	(symbol->string (vector-ref context context-idx-interface))
628	name)]
629	[iter (make-iter-append msg)] )
630	(for-each (lambda (parm)
631	(iter-append-basic iter parm)) params)
632	(free-iter iter)
633	;; TODO: pull this out into a helper function
634	(let* ( [reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
635	;; idealistic code here; todo: error checking
636	"DBusPendingCall* pending;
637	dbus_connection_send_with_reply(conn, msg, &pending, -1);
638	dbus_connection_flush(conn);
639	dbus_message_unref(msg);
640	dbus_pending_call_block(pending);
641	msg = dbus_pending_call_steal_reply(pending);
642	C_return(msg);") conn msg) ]
643	[reply-iter (make-iter reply-msg)]
644	[reply-args (iter->list reply-iter)] )
645	reply-args))))))
646
647	(define-foreign-record-type (vtable "struct DBusObjectPathVTable")
648	(constructor: make-vtable-impl)
649	(destructor: free-vtable)
650	(c-pointer unregister_function vtable-unregister_function vtable-unregister_function-set!)
651	(c-pointer message_function vtable-message_function vtable-message_function-set!)
652	(c-pointer dbus_internal_pad1 vtable-dbus_internal_pad1)
653	(c-pointer dbus_internal_pad2 vtable-dbus_internal_pad2)
654	(c-pointer dbus_internal_pad3 vtable-dbus_internal_pad3)
655	(c-pointer dbus_internal_pad4 vtable-dbus_internal_pad4))
656
657	(define (make-vtable cb unreg-cb)
658	(let ()
659	(define (fn conn msg user-data)
660	; (printf "fixin' to call ~a with ~a, ~a, ~a~%" cb conn msg user-data)
661	(let ([ret (cb conn msg user-data)])
662	;; TODO: return ret as the result
663	result-handled ))
664	(let ([ret (make-vtable-impl)])
665	(vtable-message_function-set! ret fn)
666	(vtable-unregister_function-set! ret unreg-cb)
667	ret) ))
668
669	; (set! add-match-self (lambda ()
670	; ((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
671	; (get-conn (vector-ref context context-idx-bus)) rule #f) ))
672
673	(set! read-write (lambda (conn timeout)
674	(let ()
675	((foreign-safe-lambda bool "dbus_connection_read_write" connection-ptr int)
676	conn timeout))))
677
678	(set! request-name (lambda (context)
679	(let ([service-name (symbol?->string (vector-ref context context-idx-service))])
680	(conn-or-abort (vector-ref context context-idx-bus))
681	(when service-name
682	((foreign-safe-lambda void "dbus_bus_request_name" connection-ptr c-string int error-ptr)
683	(get-conn (vector-ref context context-idx-bus))
684	service-name
685	name-flag-replace-existing #f) ))))
686
687	(set! add-match (lambda (context)
688	;; TODO is it always type signal? We are using this for methods too.
689	(let ([rule (format "type='signal', interface='~s'" (vector-ref context context-idx-interface))])
690	(conn-or-abort (vector-ref context context-idx-bus))
691	((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
692	(get-conn (vector-ref context context-idx-bus)) rule #f) )))
693
694	;; return #t if it received a message, #f if not
695	(set! poll-for-message (lambda (#!key (bus session-bus) (timeout 0))
696	(let ([conn (conn-or-abort bus)])
697	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
698	((foreign-safe-lambda* bool
699	((connection-ptr conn) (bus bus) (int timeout))
700	"DBusMessage* msg = NULL;
701	dbus_connection_read_write(conn, timeout);
702	msg = dbus_connection_pop_message(conn);
703	if (msg)
704	{
705	//printf(\"rcv: %s\\n\", dbus_message_get_interface(msg));
706	C_msg_cb(bus, msg);
707	dbus_message_unref(msg);
708	C_return(true); // yes there was a message
709	}
710	C_return (false); // we polled, we came back empty-handed
711	") conn bus timeout)
712	)))
713
714	;; TODO: one polling thread is necessary for each connection
715	(define (start-polling! bus interval)
716	(vector-set! polling-interval bus interval)
717	; (pretty-print callbacks-table)
718	(when (vector-ref polling-enabled bus)
719	(unless (vector-ref polling-threads bus)
720	(vector-set! polling-threads bus (thread-start! (lambda ()
721	(let loop ()
722	; (printf "polling~%")
723	(poll-for-message bus: bus timeout: 0)
724	(thread-sleep! (vector-ref polling-interval bus))
725	(when (vector-ref polling-enabled bus) (loop)))))))))
726
727	(set! enable-polling-thread! (lambda (#!key (bus session-bus) (enable #t) (interval default-polling-interval))
728	(vector-set! polling-enabled bus enable)
729	(if enable
730	(start-polling! bus interval)
731	(let ([th (vector-ref polling-threads bus)])
732	(when th (thread-join! th))))))
733
734	;; Wraps a user-provided callback so as to pass it the
735	;; received dbus message's parameters, and return a dbus response
736	;; with the parameter(s) returned from the callback.
737	;; msg-cb is the user-provided one.
738	(define (method-wrapper conn msg-cb)
739	(lambda (msg)
740	(let ( [args (iter->list (make-iter msg))]
741	[response ((foreign-lambda message-ptr
742	"dbus_message_new_method_return" message-ptr) msg)])
743	(let ( [ret (apply msg-cb args)]
744	[iter (make-iter-append response)] )
745	(if (pair? ret)
746	(for-each (lambda (parm)
747	; (printf "appending return parameter ~s~%" parm)
748	(iter-append-basic iter parm)) ret)
749	(iter-append-basic iter ret))
750	;; send response
751	(send-impl conn response #f)
752	(free-iter iter)
753	))))
754
755	(define (handler-wrapper conn msg-cb)
756	(lambda (msg)
757	(let ([args (iter->list (make-iter msg))])
758	(apply msg-cb args) )))
759
760	;; msg-cb: the handler implementation. Its return value is ignored.
761	(set! register-signal-handler (lambda (context name msg-cb)
762	(request-name context)
763	(add-match context)
764	(tasset! callbacks-table
765	(handler-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
766	(vector-ref context context-idx-bus)
767	(vector-ref context context-idx-path)
768	(vector-ref context context-idx-interface)
769	(string?->symbol name))
770	(start-polling! (vector-ref context context-idx-bus) default-polling-interval)
771	))
772
773	;; msg-cb: the method implementation. Its return value is sent back as the response.
774	(set! register-method (lambda (context name msg-cb)
775	(request-name context)
776	; (add-match context) doesn't seem to be necessary
777	(tasset! callbacks-table
778	(method-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
779	(vector-ref context context-idx-bus)
780	(vector-ref context context-idx-path)
781	(vector-ref context context-idx-service)
782	(vector-ref context context-idx-interface)
783	(string?->symbol name))
784	(start-polling! (vector-ref context context-idx-bus) default-polling-interval)
785	))
786
787	; dbus_bool_t dbus_connection_register_object_path (DBusConnection *connection,
788	; const char *path,
789	; const DBusObjectPathVTable *vtable,
790	; void *user_data);
791	(set! register-path (lambda (bus path fn unreg-fn)
792	; (let ([unreg-fn (lambda (parm . rest) #f)])
793	((foreign-safe-lambda bool "dbus_connection_register_object_path"
794	connection-ptr c-string vtable-ptr c-pointer)
795	(conn-or-abort bus)
796	(symbol?->string path)
797	(make-vtable fn unreg-fn) #f)))
798
799	(set! discover-api-xml (lambda (ctxt)
800	(let ([ctxt (list->vector (vector->list ctxt))]) ;; todo: efficiency?
801	(vector-set! ctxt context-idx-interface 'org.freedesktop.DBus.Introspectable)
802	(let ([xml (call ctxt "Introspect")])
803	(and (pair? xml) (car xml))))))
804
805	)) ;; end module

Note: See TracBrowser for help on using the repository browser.

Download in other formats: