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

Last change on this file since 25884 was 25884, checked in by ecloud, 9 years ago

Removed dbus: prefix; you can add it back like this: (use (prefix dbus dbus:))

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