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

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

default-signal-handler takes 5 args: bus path svc iface mber

However maybe it's a bad idea because a dbus_message has more stuff, so
the handler doesn't get enough info to actually handle the signal.
But what kind of interface is that even if it could? The idea is this
egg is to be a nice high-level abstraction, not a way of digging around
in the bowels of how libdbus does things. And if we pass the whole message
to this handler, it's a C object, so what if the handler tries to keep it
for too long. Have never addressed GC yet anyway.

File size: 35.7 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 #!optional port)
193        (lambda (bus path svc iface mber)
194                (let ([str (format "failed to find callback for ~a ~a ~a ~a on ~a~%" path svc iface mber (bus-name bus))])
195                        (if port
196                                (display str port)
197                                (display str)))))
198
199(define dump-callback-table)
200
201(define-foreign-type error-ptr c-pointer) ;; DBusError*
202(define-foreign-type connection-ptr c-pointer)  ;; DBusConnection*
203(define-foreign-type message-ptr c-pointer)     ;; DBusMessage*
204(define-foreign-type uint-ptr c-pointer)        ;; dbus_uint32_t*
205(define-foreign-type message-iter-ptr c-pointer)        ;; DBusMessageIter*
206(define-foreign-type vtable-ptr c-pointer)      ;; DBusObjectPathVTable*
207
208(define (discover-services #!key (bus session-bus))
209        (let* ([ctxt (make-context
210                                        bus: bus
211                                        service: 'org.freedesktop.DBus
212                                        interface: 'org.freedesktop.DBus
213                                        path: '/org/freedesktop/DBus)]
214                        [services (call ctxt "ListNames")])
215                (and (pair? services) (vector? (car services)) (vector->list (car services)))))
216
217(define discover-api-xml)
218
219(define-external (C_msg_cb (bus bus) (message-ptr msg)) bool
220        (let* ([cb (find-callback bus msg)][found (procedure? cb)])
221                ; (printf "got a message: ~s on bus ~a and found callback ~s~%" msg bus cb)
222                (when found
223                        (cb msg))
224                found
225        ))
226
227(let ([connections '()] ;; an alist mapping bus to DBusConnection ptrs
228                [error (foreign-value "&err" c-pointer)]
229                ;; indices in a "context" vector
230                [context-idx-ID 0]
231                [context-idx-bus 1]
232                [context-idx-service 2]
233                [context-idx-path 3]
234                [context-idx-interface 4]
235                [context-count 0]
236                [default-polling-interval 0.01]
237                [polling-interval (make-vector known-bus-count 0.01)]
238                [polling-enabled (make-vector known-bus-count #t)]
239                [polling-threads (make-vector known-bus-count #f)]
240                ;; will become an assoc tree:
241                ;; bus
242                ;;   path
243                ;;     service (unless it's a signal callback)
244                ;;       interface
245                ;;         method
246                ;;           callback-fn
247                [callbacks-table `((,system-bus . #f) (,session-bus . #f))]
248                [iterm (gensym 'terminiter)] )
249
250    (define (any->string arg)
251                (if (string? arg)
252                        arg
253                        (if (eq? (void) arg)
254                          ""
255                          (format "~a" arg))))
256
257        (define (symbol?->string arg)
258                (if (symbol? arg)
259                        (symbol->string arg)
260                        arg))
261
262        (define (string?->symbol arg)
263                (if (string? arg)
264                        (string->symbol arg)
265                        arg))
266
267        (define (ascii->string a) (string (integer->char a)))
268
269        (define (vector-for-each fn v)
270                (let ([len (vector-length v)])
271                        (let loop ([i 0])
272                                (when (< i len)
273                                        (fn i (vector-ref v i))
274                                        (loop (+ 1 i))))))
275
276        ;; If the assq-list has the given key, replace its value.
277        ;; Else add the key-value pair.
278        (define (asset! alist key val)
279                (let ([pr (assq key alist)])
280                        (if pr
281                                (set-cdr! pr val)
282                                (if (null? (cdar alist))
283                                        (set-car! alist (cons key val))
284                                        (begin
285                                                (set-cdr! alist (cons (car alist) (cdr alist)))
286                                                (set-car! alist (cons key val))) ))))
287
288        ;; The "tree" version of assq: drills down into an assq-tree
289        ;; as directed by the sequence of keys, and returns the value found.
290        ;; #f means not found (so it is not useful to store #f in such a tree).
291        (define (tassq tree . keys)
292                (let ([key-list (if (pair? (car keys)) (car keys) keys)])
293                        (let loop ([rem-keys key-list][subtree tree])
294                                (cond
295                                        [(null? rem-keys)       subtree]
296                                        [(not subtree) #f]
297                                        [else (loop (cdr rem-keys)
298                                                (let ([pr (assq (car rem-keys) subtree)])
299                                                        (and (pair? pr) (cdr pr))))]))))
300
301        ;; The "tree" version of asset!: drills down into an assq-tree
302        ;; as directed by the sequence of keys, making new branches as necessary,
303        ;; and sets the given value as a leaf at that point in the tree.
304        ;; return value is undefined
305        (define (tasset! tree val . keys)
306                (let ([key-list (if (pair? (car keys)) (car keys) keys)])
307                        (let loop ([rem-keys (cdr key-list)]
308                                                [subtree (tassq tree (car key-list))]
309                                                [prev-key (car key-list)]
310                                                [prev-subtree tree])
311; (printf "rem-keys ~s subtree ~s prev-key ~s prev-subtree ~s~%" rem-keys subtree prev-key prev-subtree)
312                                (when (and (not subtree) (pair? rem-keys))
313                                        (set! subtree (list (cons (car rem-keys) #f)))
314; (printf "   creating subtree ~s within ~s~%" subtree prev-subtree)
315                                        (asset! prev-subtree prev-key subtree)
316; (pretty-print prev-subtree)
317                                )
318                                (if (null? rem-keys)
319                                        (asset! prev-subtree prev-key val)
320                                        (loop
321                                                (cdr rem-keys)
322                                                (let ([pr (assq (car rem-keys) subtree)])
323                                                        (unless (pair? pr)
324                                                                (set! pr (cons (car rem-keys) #f))
325                                                                (set-cdr! subtree (cons (car subtree) (cdr subtree)))
326                                                                (set-car! subtree pr) )
327                                                        (cdr pr))
328                                                (car rem-keys)
329                                                subtree )))))
330
331        (set! dump-callback-table (lambda ()
332                (for-each (lambda (bus)
333                        (printf "~a:~%" (bus-name (car bus)))
334                        (if (cdr bus)
335                                (for-each (lambda (path)
336                                        (printf "   ~a~%" (car path))
337                                        (for-each (lambda (iface)
338                                                (printf "    ~a~%" (car iface)) (pp (cdr iface))) (cdr path)))
339                                        (cdr bus))
340                                (printf "   no callbacks registered~%")
341                        ))
342                        callbacks-table)))
343
344        (define (next-context-ID) (set! context-count (+ 1 context-count)) context-count)
345
346        (define (get-conn bus-type)
347                (let ([conn (assq bus-type connections)])
348                        (if (pair? conn)
349                                (set! conn (cdr conn))
350                                (begin
351                                        (set! conn ((foreign-lambda connection-ptr "dbus_bus_get" bus error-ptr)
352                                                bus-type error) )
353                                        (when conn
354                                                (set! connections (cons (cons bus-type conn) connections)))))
355                        conn))
356
357        (define (conn-or-abort bus-type)
358                (or (get-conn bus-type)
359                        (abort (format "unable to connect to bus ~s~%" bus-type))))
360
361        (define (exists-or-abort datum err-str)
362                (or datum
363                        (abort err-str)))
364
365        ;; params: path interface name
366        ;; todo: garbage-collect this
367        (define make-signal (foreign-lambda message-ptr "dbus_message_new_signal"
368                c-string c-string c-string))
369
370        ;; params: service path interface method-name
371        ;; todo: garbage-collect this
372        (define make-message (foreign-lambda message-ptr "dbus_message_new_method_call"
373                c-string c-string c-string c-string))
374
375        (define make-error
376                (foreign-lambda* (c-pointer (struct "DBusError")) ()
377                 "DBusError err;
378                  dbus_error_init(&err);
379                  C_return(&err);"))
380
381        (define free-error!
382                (foreign-lambda* void (((c-pointer (struct "DBusError")) err))
383                        "dbus_error_free(err);"))
384
385        (define (raise-dbus-error location err)
386                (let ((err-name
387                        ((foreign-lambda* c-string (((c-pointer (struct "DBusError")) err))
388                                          "C_return(err->name);")
389                         err))
390                      (err-message
391                       ((foreign-lambda* c-string (((c-pointer (struct "DBusError")) err))
392                                         "C_return(err->message);")
393                        err)))
394                  (free-error! err)
395                  (signal
396                   (make-composite-condition
397                    (make-property-condition 'dbus-call)
398                    (make-property-condition
399                     'exn
400                     'location location
401                     'message (string-append "(" err-name "): " err-message))))))
402
403        ;; todo: garbage-collect this
404        (define make-iter-append
405                (foreign-lambda* message-iter-ptr ((message-ptr msg))
406                        "DBusMessageIter* iter = malloc(sizeof(DBusMessageIter));
407                        dbus_message_iter_init_append (msg, iter);
408                        C_return (iter);"))
409
410        (define iter-append-basic-string
411                (foreign-lambda* bool ((message-iter-ptr iter) (c-string v))
412                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_STRING, &v));"))
413
414        (define iter-append-basic-object-path
415                (foreign-lambda* bool ((message-iter-ptr iter) (c-string v))
416                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_OBJECT_PATH, &v));"))
417
418        (define iter-append-basic-bool
419                (foreign-lambda* bool ((message-iter-ptr iter) (bool v))
420                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BOOLEAN, &v));"))
421
422        (define iter-append-basic-int
423                (foreign-lambda* bool ((message-iter-ptr iter) (int v))
424                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT32, &v));"))
425
426        (define iter-append-basic-double
427                (foreign-lambda* bool ((message-iter-ptr iter) (double v))
428                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_DOUBLE, &v));"))
429
430        (define iter-append-basic-byte
431                (foreign-lambda* bool ((message-iter-ptr iter) (int v))
432                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BYTE, &v));"))
433
434        (define iter-append-basic-int16
435                (foreign-lambda* bool ((message-iter-ptr iter) (int v))
436                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT16, &v));"))
437
438        (define iter-append-basic-uint32
439                (foreign-lambda* bool ((message-iter-ptr iter) (unsigned-integer32 v))
440                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT32, &v));"))
441
442        (define iter-append-basic-uint16
443                (foreign-lambda* bool ((message-iter-ptr iter) (unsigned-short v))
444                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT16, &v));"))
445
446        (define iter-append-basic-int64
447                (foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
448                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT64, &v));"))
449
450        (define iter-append-basic-uint64
451                (foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
452                        "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &v));"))
453
454        (define (value-signature val)
455; (printf "value-signature ~s~%" val)
456                (cond
457                        [(string? val) (ascii->string type-string)]
458                        [(object-path? val) (ascii->string type-object-path)]
459                        [(fixnum? val) (ascii->string type-fixnum)]
460                        [(flonum? val) (ascii->string type-flonum)]
461                        [(boolean? val) (ascii->string type-boolean)]
462                        [(variant? val) (ascii->string type-variant)]
463                        [(struct? val) (format "~a~a~a" (ascii->string type-struct-begin)
464                                (apply string-append (map value-signature (vector->list (struct->vector val)))) (ascii->string type-struct-end))]
465                        [(vector? val) (format "~a~a" (ascii->string type-array) (value-signature (vector-ref val 0)))]
466                        ; [(variant? val) (value-signature (variant-data val))]
467                        [(pair? val)
468                                (if (list? val)
469                                        "unsupported" ;; todo
470                                        (format "~a~a~a~a" (integer->char type-dict-entry-begin)
471                                                (value-signature (car val)) (value-signature (cdr val))(integer->char type-dict-entry-end))
472                                )]
473                ))
474
475        (define (iter-append-basic-variant iter val)
476; (printf "iter-append-basic-variant ~s~%" val)
477                (let ([signature (value-signature val)])
478; (printf "iter-append-basic-variant: sig ~s~%" signature)
479                        (let ([container ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter) (c-string signature))
480                                        "DBusMessageIter* container = malloc(sizeof(DBusMessageIter));
481                                        dbus_message_iter_open_container(iter, DBUS_TYPE_VARIANT, signature, container);
482                                        C_return(container);") iter signature)])
483                                (iter-append-basic container val)
484                                ((foreign-lambda* bool ((message-iter-ptr iter)(message-iter-ptr container))
485                                        "bool ret = dbus_message_iter_close_container(iter, container);
486                                        free(container);
487                                        C_return(ret);") iter container) ) ))
488
489        (define (iter-append-basic-struct iter val)
490; (printf "iter-append-basic-struct ~s~%" val)
491                (let ([container ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter))
492                                "DBusMessageIter* container = malloc(sizeof(DBusMessageIter));
493                                dbus_message_iter_open_container(iter, DBUS_TYPE_STRUCT, NULL, container);
494                                C_return(container);") iter)])
495                        (vector-for-each (lambda (i field) (iter-append-basic container field)) val)
496                        ((foreign-lambda* bool ((message-iter-ptr iter)(message-iter-ptr container))
497                                "bool ret = dbus_message_iter_close_container(iter, container);
498                                free(container);
499                                C_return (ret);") iter container) ) )
500
501        (define (iter-append-dict-entry iter pair)
502; (printf "iter-append-dict-entry ~s : ~s~%" (car pair)(cdr pair))
503                (let ([signature (value-signature pair)])
504                        (let ([container ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter) (c-string signature))
505                                        "DBusMessageIter* container = malloc(sizeof(DBusMessageIter));
506                                        dbus_message_iter_open_container(iter, DBUS_TYPE_DICT_ENTRY, NULL, container);
507                                        C_return(container);") iter signature)])
508                                (iter-append-basic container (car pair))
509                                (iter-append-basic container (cdr pair))
510                                ((foreign-lambda* bool ((message-iter-ptr iter)(message-iter-ptr container))
511                                        "bool ret = dbus_message_iter_close_container(iter, container);
512                                        free(container);
513                                        C_return(ret);") iter container) ) ))
514
515        ;; The first element of the vector determines the signature, so all elements must have the same signature.
516        (define (iter-append-uniform-array iter vec)
517; (printf "iter-append-uniform-array ~s~%" vec)
518                (if (> (vector-length vec) 0)
519                        ; (let ([signature (format "~a~a" (ascii->string type-array) (value-signature (vector-ref vec 0)))])
520                        (let ([signature (value-signature (vector-ref vec 0))])
521; (printf "value signature ~s~%" signature)
522                                (let ([container ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter) (c-string signature))
523                                                "DBusMessageIter* container = malloc(sizeof(DBusMessageIter));
524                                                dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature, container);
525                                                C_return(container);") iter signature)])
526                                        (vector-for-each (lambda (i val)
527; (printf "iter-append array element ~s ~s~%" i val)
528                                                (iter-append-basic container val) ) vec)
529                                        ((foreign-lambda* bool ((message-iter-ptr iter)(message-iter-ptr container))
530                                                "bool ret = dbus_message_iter_close_container(iter, container);
531                                                free(container);
532                                                C_return(ret);") iter container) ) )
533                        ;; else todo: append empty array
534                        ))
535
536        ;; TODO: iter-append-basic-object-path
537
538        ;; val would usually be a single value, but
539        ;; could be a pair of the form (type-x . value)
540        ;; in which case we will attempt to convert the value to that type for sending.
541        (define (iter-append-basic iter val)
542; (printf "iter-append-basic ~s ~s~%"   iter val)
543                (cond
544                        [(fixnum? val) (iter-append-basic-int iter val)]
545                        [(flonum? val) (iter-append-basic-double iter val)]
546                        [(boolean? val) (iter-append-basic-bool iter val)]
547                        [(variant? val) (iter-append-basic-variant iter (variant-data val))]
548                        [(struct? val) (iter-append-basic-struct iter (struct->vector val))]
549                        [(vector? val) (iter-append-uniform-array iter val)]
550                        [(and (pair? val) (not (list? val))) (iter-append-dict-entry iter val)]
551                        [(object-path? val) (iter-append-basic-object-path iter (object-path->string val))]
552                        [else (iter-append-basic-string iter (any->string val))] ))
553
554        (define free-iter (foreign-lambda* void ((message-iter-ptr i)) "free(i);"))
555
556        (define (iter-cond iter)
557                (let ([type ((foreign-lambda int "dbus_message_iter_get_arg_type"
558                                                message-iter-ptr) iter)] )
559                        ; (printf "iter-cond type ~s~%" type)
560                        (cond
561                                [(eq? type type-string)
562                                        ((foreign-lambda* c-string ((message-iter-ptr iter))
563                                                "char* ret = NULL;
564                                                dbus_message_iter_get_basic(iter, &ret);
565                                                C_return (ret);") iter)]
566                                [(eq? type type-object-path)
567                                        (let ([str ((foreign-lambda* c-string ((message-iter-ptr iter))
568                                                "char* ret = NULL;
569                                                dbus_message_iter_get_basic(iter, &ret);
570                                                C_return (ret);") iter)])
571                                                (if (auto-unbox-object-paths)
572                                                        str
573                                                        (string->object-path str)))]
574                                [(eq? type type-boolean)
575                                        ((foreign-lambda* bool ((message-iter-ptr iter))
576                                                "bool ret;
577                                                dbus_message_iter_get_basic(iter, &ret);
578                                                return (ret);") iter)]
579                                [(memq type `(,type-int32 ,type-byte
580                                                                ,type-int16 ))
581                                        ((foreign-lambda* int ((message-iter-ptr iter))
582                                                "int ret = 0;
583                                                dbus_message_iter_get_basic(iter, &ret);
584                                                C_return (ret);") iter)]
585                                [(memq type `(,type-uint32 ,type-uint16))
586                                        ((foreign-lambda* unsigned-int ((message-iter-ptr iter))
587                                                "unsigned int ret = 0;
588                                                dbus_message_iter_get_basic(iter, &ret);
589                                                C_return (ret);") iter)]
590                                [(memq type `(,type-flonum ,type-uint64))
591                                        ;; todo don't put 64-bit int into a flonum if there's another way
592                                        ((foreign-lambda* double ((message-iter-ptr iter))
593                                                "double ret;
594                                                dbus_message_iter_get_basic(iter, &ret);
595                                                C_return (ret);") iter)]
596                                [(eq? type type-int64)
597                                        ((foreign-lambda* integer64 ((message-iter-ptr iter))
598                                                "int64_t ret = 0;
599                                                dbus_message_iter_get_basic(iter, &ret);
600                                                C_return (ret);") iter)]
601                                [(eq? type type-array)
602                                        (let ([v  (iter->vector (make-sub-iter iter))])
603                                                (when (and (vector? v) (eq? 1 (vector-length v)) (unsupported-type? (vector-ref v 0)))
604                                                        (set! v (make-vector 0)))
605                                                v)]
606                                [(eq? type type-dict-entry)
607                                        (iter->pair (make-sub-iter iter))]
608                                [(eq? type type-struct)
609                                        (let ([v (iter->vector (make-sub-iter iter))])
610                                                (if (auto-unbox-structs) v (vector->struct v)))]
611                                [(eq? type type-variant)
612                                        (if (auto-unbox-variants)
613                                                ((make-sub-iter iter))
614                                                (make-variant ((make-sub-iter iter))))]
615
616                                ;; todo: unsupported so far (not understood well enough):
617                                ;;      type-object-path and type-signature
618
619                                ;; so far the DBus "invalid" type is treated the same as unsupported.
620                                ;; Maybe need a distinction though...
621                                ; [(eq? type type-invalid) ...]
622                                [else (make-unsupported-type (integer->char type))] )))
623
624        (define (make-sub-iter iter)
625                (let* ([sub ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter))
626                                "DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
627                                dbus_message_iter_recurse(iter, i);
628                                C_return (i);") iter) ]
629                                [has-next sub]
630                                )
631                        (lambda ()
632                                (if has-next
633                                        (let ([ret (iter-cond sub)])
634                                                (set! has-next ((foreign-lambda bool
635                                                        "dbus_message_iter_next" message-iter-ptr) sub))
636                                                ret     )
637                                        (begin
638                                                (free-iter sub)
639                                                iterm)
640                                ))))
641
642        ;; iterator for reading parameters from a message
643        ;; returns a lambda which provides one param at a time, terminating with (void)
644        (define (make-iter msg)
645                (let* ([iter ((foreign-lambda* message-iter-ptr ((message-ptr msg))
646                                "DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
647                                if (!dbus_message_iter_init (msg, i))
648                                        i = (DBusMessageIter*)0;        // Message has no parameters
649                                C_return (i);") msg) ]
650                                [has-next iter]
651                                )
652                        (lambda ()
653                                (if has-next
654                                        (let ([ret (iter-cond iter)])
655                                                (set! has-next ((foreign-lambda bool
656                                                        "dbus_message_iter_next" message-iter-ptr) iter))
657                                                ret     )
658                                        (begin
659                                                (free-iter iter)
660                                                iterm) ))))
661
662        ;; todo maybe: rewrite to avoid the reverse
663        (define (iter->list iter)
664                (let loop ([retval '()])
665                        (let ([next (iter)])
666                                (if (eq? next iterm)
667                                        (reverse retval)
668                                        (loop (cons next retval))))))
669
670        (define (iter->pair iter)
671                (cons (iter) (iter)))
672
673        (define (iter->vector iter)
674                (let ([l (iter->list iter)])
675                        (list->vector l)))
676
677        (define msg-path
678                (foreign-lambda c-string "dbus_message_get_path" message-ptr))
679
680        (define msg-interface
681                (foreign-lambda c-string "dbus_message_get_interface" message-ptr))
682
683        (define msg-member
684                (foreign-lambda c-string "dbus_message_get_member" message-ptr))
685
686        (define msg-error-name
687                (foreign-lambda c-string "dbus_message_get_error_name" message-ptr))
688
689        (define msg-service
690                (foreign-lambda c-string "dbus_message_get_destination" message-ptr))
691
692        (set! find-callback (lambda (bus msg)
693                (let ([path (string?->symbol (msg-path msg))]
694                                [iface (string?->symbol (msg-interface msg))]
695                                [mber (string?->symbol (msg-member msg))]
696                                [svc (string?->symbol (msg-service msg))]
697                                )
698                        ; (printf "   svc ~s~%" svc)
699                        ; (printf "   path ~s~%" path)
700                        ; (printf "   iface ~s~%" iface)
701                        ; (printf "   mber ~s~%" mber)
702                        ;; The service name is not included as part of the signal, so svc will be #f.
703                        ;; In that case the callback is registered under bus/path/iface/signal-name.
704                        (let ([ret (and svc
705                                                (tassq callbacks-table bus path svc iface mber))])
706                                (unless ret (set! ret
707                                                (tassq callbacks-table bus path iface mber) ))
708                                (unless ret
709                                        (when (default-signal-handler)
710                                                ((default-signal-handler) bus path svc iface mber)))
711                                ret))))
712
713        (set! make-context (lambda (#!key (bus session-bus) service interface (path "/"))
714                (vector (next-context-ID) bus (string?->symbol service)
715                        (string?->symbol path) (string?->symbol interface)) ))
716
717        (define send-impl
718                (foreign-lambda int "dbus_connection_send" connection-ptr message-ptr uint-ptr))
719
720        (set! send (lambda (context name . params)
721                (let* ([service (symbol?->string (vector-ref context context-idx-service))]
722                                [msg (make-signal
723                                                        (symbol?->string (vector-ref context context-idx-path))
724                                                        (symbol?->string (vector-ref context context-idx-interface))
725                                                        name)]
726                                [iter (make-iter-append msg)] )
727                        (let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
728                                ; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
729                                (for-each (lambda (parm)
730                                        (iter-append-basic iter parm))  params)
731                                (send-impl conn msg #f)
732                                (free-iter iter)
733                                ; ((foreign-lambda void "dbus_connection_flush" connection-ptr) conn)
734                        ))))
735
736        (set! call (lambda (context name . params)
737                (let* ([service (symbol->string (vector-ref context context-idx-service))]
738                                [msg (make-message service
739                                                        (symbol->string (vector-ref context context-idx-path))
740                                                        (symbol->string (vector-ref context context-idx-interface))
741                                                        name)]
742                                [iter (make-iter-append msg)] )
743                        (let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
744                                ; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
745                                (for-each (lambda (parm)
746                                        (iter-append-basic iter parm))  params)
747                                (free-iter iter)
748                                (let* ([err (make-error)]
749                                                [reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg)
750                                                                        ((c-pointer (struct "DBusError")) err))
751                                                        ;; todo: timeout comes from where?  (make-parameter) maybe
752                                                        "DBusMessage *reply;
753                                                        reply = dbus_connection_send_with_reply_and_block(conn, msg, 5000, err);
754                                                        dbus_message_unref(msg);
755                                                        C_return(reply);") conn msg err) ])
756                                        (if reply-msg
757                                                        (let* ([reply-iter (make-iter reply-msg)]
758                                                                                 [reply-args (iter->list reply-iter)] )
759                                                                reply-args)
760                                                        (raise-dbus-error 'call err)))))))
761
762
763        (set! make-method-proxy (lambda (context name)
764                (let ([service (symbol->string (vector-ref context context-idx-service))]
765                                [conn (conn-or-abort (vector-ref context context-idx-bus))] )
766                                ; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
767                                (lambda params
768                                        (let* ([msg (make-message service
769                                                                        (symbol->string (vector-ref context context-idx-path))
770                                                                        (symbol->string (vector-ref context context-idx-interface))
771                                                                        name)]
772                                                        [iter (make-iter-append msg)] )
773                                                (for-each (lambda (parm)
774                                                        (iter-append-basic iter parm))  params)
775                                                (free-iter iter)
776                                                ;; TODO: pull this out into a helper function
777                                                (and-let* ([reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
778                                                                        ;; idealistic code here; todo: error checking
779                                                                        "DBusPendingCall* pending;
780                                                                        dbus_connection_send_with_reply(conn, msg, &pending, -1);
781                                                                        dbus_connection_flush(conn);
782                                                                        dbus_message_unref(msg);
783                                                                        dbus_pending_call_block(pending);
784                                                                        msg = dbus_pending_call_steal_reply(pending);
785                                                                        C_return(msg);") conn msg) ]
786                                                                [reply-iter (make-iter reply-msg)]
787                                                                [reply-args (iter->list reply-iter)] )
788                                                        reply-args))))))
789
790        (define-foreign-record-type (vtable "struct DBusObjectPathVTable")
791                (constructor: make-vtable-impl)
792                (destructor: free-vtable)
793                (c-pointer unregister_function vtable-unregister_function vtable-unregister_function-set!)
794                (c-pointer message_function vtable-message_function vtable-message_function-set!)
795                (c-pointer dbus_internal_pad1 vtable-dbus_internal_pad1)
796                (c-pointer dbus_internal_pad2 vtable-dbus_internal_pad2)
797                (c-pointer dbus_internal_pad3 vtable-dbus_internal_pad3)
798                (c-pointer dbus_internal_pad4 vtable-dbus_internal_pad4))
799
800        (define (make-vtable cb unreg-cb)
801                (let ()
802                        (define (fn conn msg user-data)
803                                ; (printf "fixin' to call ~a with ~a, ~a, ~a~%" cb conn msg user-data)
804                                (let ([ret (cb conn msg user-data)])
805                                        ;; TODO: return ret as the result
806                                        result-handled ))
807                        (let ([ret (make-vtable-impl)])
808                                (vtable-message_function-set! ret fn)
809                                (vtable-unregister_function-set! ret unreg-cb)
810                                ret) ))
811
812        ; (set! add-match-self (lambda ()
813                ; ((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
814                        ; (get-conn (vector-ref context context-idx-bus)) rule #f) ))
815
816        (set! read-write (lambda (conn timeout)
817                (let ()
818                        ((foreign-safe-lambda bool "dbus_connection_read_write" connection-ptr int)
819                                conn timeout))))
820
821        (set! request-name (lambda (context)
822                (let ([service-name (symbol?->string (vector-ref context context-idx-service))])
823                        (conn-or-abort (vector-ref context context-idx-bus))
824                        (when service-name
825                                ((foreign-safe-lambda void "dbus_bus_request_name" connection-ptr c-string int error-ptr)
826                                        (get-conn (vector-ref context context-idx-bus))
827                                        service-name
828                                        name-flag-replace-existing #f) ))))
829
830        (set! add-match (lambda (context)
831                ;; TODO is it always type signal?  We are using this for methods too.
832                (let ([rule (format "type='signal', interface='~s'" (vector-ref context context-idx-interface))])
833                        (conn-or-abort (vector-ref context context-idx-bus))
834                        ((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
835                                (get-conn (vector-ref context context-idx-bus)) rule #f) )))
836
837        ;; return #t if it received a message, #f if not
838        (set! poll-for-message (lambda (#!key (bus session-bus) (timeout 0))
839                (let ([conn (conn-or-abort bus)])
840                        ; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
841                        ((foreign-safe-lambda* bool
842                                ((connection-ptr conn) (bus bus) (int timeout))
843                                "DBusMessage* msg = NULL;
844                                dbus_connection_read_write(conn, timeout);
845                                msg = dbus_connection_pop_message(conn);
846                                if (msg)
847                                {
848                                        //printf(\"rcv: %s\\n\", dbus_message_get_interface(msg));
849                                        C_msg_cb(bus, msg);
850                                        dbus_message_unref(msg);
851                                        C_return(true);         // yes there was a message
852                                }
853                                C_return (false);               // we polled, we came back empty-handed
854                                ") conn bus timeout)
855                )))
856
857        ;; TODO: one polling thread is necessary for each connection
858        (define (start-polling! bus interval)
859                (vector-set! polling-interval bus interval)
860                ; (pretty-print callbacks-table)
861                (when (vector-ref polling-enabled bus)
862                        (unless (vector-ref polling-threads bus)
863                                (vector-set! polling-threads bus (thread-start! (lambda ()
864                                        (let loop ()
865                                                ; (printf "polling~%")
866                                                (poll-for-message bus: bus timeout: 0)
867                                                (thread-sleep! (vector-ref polling-interval bus))
868                                                (when (vector-ref polling-enabled bus) (loop)))))))))
869
870        (set! enable-polling-thread! (lambda (#!key (bus session-bus) (enable #t) (interval default-polling-interval))
871                (vector-set! polling-enabled bus enable)
872                (if enable
873                        (start-polling! bus interval)
874                        (let ([th (vector-ref polling-threads bus)])
875                                (when th (thread-join! th))))))
876
877        ;; Wraps a user-provided callback so as to pass it the
878        ;; received dbus message's parameters, and return a dbus response
879        ;; with the parameter(s) returned from the callback.
880        ;; msg-cb is the user-provided one.
881        (define (method-wrapper conn msg-cb)
882                (lambda (msg)
883                        (let ([args (iter->list (make-iter msg))]
884                                        [response ((foreign-lambda message-ptr
885                                                        "dbus_message_new_method_return" message-ptr) msg)])
886                                (let ([ret (apply msg-cb args)]
887                                                [iter (make-iter-append response)] )
888                                        (if (pair? ret)
889                                                (for-each (lambda (parm)
890                                                        ; (printf "appending return parameter ~s~%" parm)
891                                                        (iter-append-basic iter parm))  ret)
892                                                (iter-append-basic iter ret))
893                                        ;; send response
894                                        (send-impl conn response #f)
895                                        (free-iter iter)
896                                        ))))
897
898        (define (handler-wrapper conn msg-cb)
899                (lambda (msg)
900                        (let ([args (iter->list (make-iter msg))])
901                                (apply msg-cb args)     )))
902
903        ;; msg-cb: the handler implementation.  Its return value is ignored.
904        (set! register-signal-handler (lambda (context name msg-cb)
905                (request-name context)
906                (add-match context)
907                (tasset! callbacks-table
908                        (handler-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
909                        (vector-ref context context-idx-bus)
910                        (vector-ref context context-idx-path)
911                        (vector-ref context context-idx-interface)
912                        (string?->symbol name))
913                (start-polling! (vector-ref context context-idx-bus) default-polling-interval)
914        ))
915
916        ;; msg-cb: the method implementation.  Its return value is sent back as the response.
917        (set! register-method (lambda (context name msg-cb)
918                (request-name context)
919                ; (add-match context)   doesn't seem to be necessary
920                (tasset! callbacks-table
921                        (method-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
922                        (vector-ref context context-idx-bus)
923                        (vector-ref context context-idx-path)
924                        (vector-ref context context-idx-service)
925                        (vector-ref context context-idx-interface)
926                        (string?->symbol name))
927                (start-polling! (vector-ref context context-idx-bus) default-polling-interval)
928        ))
929
930        ; dbus_bool_t dbus_connection_register_object_path   (DBusConnection              *connection,
931                                                                                                                ; const char                  *path,
932                                                                                                                ; const DBusObjectPathVTable  *vtable,
933                                                                                                                ; void                        *user_data);
934        (set! register-path (lambda (bus path fn unreg-fn)
935                ; (let ([unreg-fn (lambda (parm . rest) #f)])
936                ((foreign-safe-lambda bool "dbus_connection_register_object_path"
937                                connection-ptr c-string vtable-ptr c-pointer)
938                        (conn-or-abort bus)
939                        (symbol?->string path)
940                        (make-vtable fn unreg-fn) #f)))
941
942        (set! discover-api-xml (lambda (ctxt)
943                (let ([ctxt (list->vector (vector->list ctxt))])        ;; todo: efficiency?
944                        (vector-set! ctxt context-idx-interface 'org.freedesktop.DBus.Introspectable)
945                        (let ([xml (call ctxt "Introspect")])
946                                (and (pair? xml) (car xml))))))
947
948)) ;; end module
Note: See TracBrowser for help on using the repository browser.