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

Last change on this file since 32267 was 32267, checked in by ecloud, 6 years ago

set-finalize! DBusError; explicit c pointer types on the other foreign types

It seems we hopefully don't need to do anything to free a DBusMessageIter.

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