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

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

got rid of duplication

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