OCaml DBUS
Have you guys got any plans around D-Bus support for OCaml?
http://tab.snarc.org/projects/ocaml_dbus/
Unfortunately upstream is being a bit unresponsive. I submitted a
patch against 0.03 (attached) about 4 weeks ago which hasn't been
committed yet. I also asked the author if he would like to open the
development process up, but also there has been no movement on that.
It's in Fedora: https://bugzilla.redhat.com/show_bug.cgi?id=428000 but
I haven't applied my patch because I don't want to fork from upstream
(yet).
Rich.
--
Richard Jones
Red Hat
Index: dBus.ml
===================================================================
RCS file: /home/remote/rjones/cvsroot/redhat/ocaml_dbus/dBus.ml,v
retrieving revision 1.1
diff -u -r1.1 dBus.ml
--- dBus.ml 9 Jan 2008 11:01:27 -0000 1.1
+++ dBus.ml 9 Jan 2008 16:37:06 -0000
@@ -13,6 +13,8 @@
* Dbus binding
*)
+open Printf
+
type error
type bus
type message
@@ -22,10 +24,31 @@
| Byte of char
| Bool of bool
| Int16 of int
+ | UInt16 of int
| Int32 of int32
+ | UInt32 of int32
| Int64 of int64
+ | UInt64 of int64
| Double of float
| String of string
+ | ObjectPath of string
+
+let string_of_ty = function
+ | Byte c -> sprintf "%C" c
+ | Bool true -> sprintf "true"
+ | Bool false -> sprintf "false"
+ | Int16 i -> sprintf "short(%d)" i
+ | UInt16 i -> sprintf "ushort(%d)" i
+ | Int32 i -> sprintf "int(%ld)" i
+ | UInt32 i -> sprintf "uint(%ld)" i
+ | Int64 i -> sprintf "long(%Ld)" i
+ | UInt64 i -> sprintf "long(%Ld)" i
+ | Double d -> sprintf "%g" d
+ | String s -> sprintf "%S" s
+ | ObjectPath s -> sprintf "path(%S)" s
+
+let string_of_ty_list xs =
+ String.concat ", " (List.map string_of_ty xs)
(******************* ERROR *********************)
module Error = struct
@@ -96,13 +119,13 @@
external get_type : message -> message_type = "stub_dbus_message_get_type"
-external get_path : message -> string = "stub_dbus_message_get_path"
-external get_interface : message -> string = "stub_dbus_message_get_interface"
-external get_member : message -> string = "stub_dbus_message_get_member"
-external get_error_name : message -> string = "stub_dbus_message_get_error_name"
-external get_destination : message -> string = "stub_dbus_message_get_destination"
-external get_sender : message -> string = "stub_dbus_message_get_sender"
-external get_signature : message -> string = "stub_dbus_message_get_signature"
+external get_path : message -> string option = "stub_dbus_message_get_path"
+external get_interface : message -> string option = "stub_dbus_message_get_interface"
+external get_member : message -> string option = "stub_dbus_message_get_member"
+external get_error_name : message -> string option = "stub_dbus_message_get_error_name"
+external get_destination : message -> string option = "stub_dbus_message_get_destination"
+external get_sender : message -> string option = "stub_dbus_message_get_sender"
+external get_signature : message -> string option = "stub_dbus_message_get_signature"
external get_serial : message -> int32 = "stub_dbus_message_get_serial"
external get_reply_serial : message -> int32
= "stub_dbus_message_get_reply_serial"
@@ -122,10 +145,14 @@
= "stub_dbus_connection_send"
external send_with_reply : bus -> message -> int -> pending_call
= "stub_dbus_connection_send_with_reply"
+external send_with_reply_and_block : bus -> message -> int -> error -> message
+ = "stub_dbus_connection_send_with_reply_and_block"
external add_filter : bus -> (bus -> message -> bool) -> unit
= "stub_dbus_connection_add_filter"
external flush : bus -> unit = "stub_dbus_connection_flush"
-external read_write : bus -> int -> unit = "stub_dbus_connection_read_write"
+external read_write : bus -> int -> bool = "stub_dbus_connection_read_write"
+external read_write_dispatch : bus -> int -> bool
+ = "stub_dbus_connection_read_write_dispatch"
external pop_message : bus -> message option
= "stub_dbus_connection_pop_message"
external get_fd : bus -> Unix.file_descr = "stub_dbus_connection_get_fd"
Index: dBus.mli
===================================================================
RCS file: /home/remote/rjones/cvsroot/redhat/ocaml_dbus/dBus.mli,v
retrieving revision 1.1
diff -u -r1.1 dBus.mli
--- dBus.mli 9 Jan 2008 11:01:27 -0000 1.1
+++ dBus.mli 9 Jan 2008 16:37:06 -0000
@@ -21,10 +21,17 @@
| Byte of char
| Bool of bool
| Int16 of int
+ | UInt16 of int
| Int32 of int32
+ | UInt32 of int32
| Int64 of int64
+ | UInt64 of int64
| Double of float
| String of string
+ | ObjectPath of string
+
+val string_of_ty : ty -> string
+val string_of_ty_list : ty list -> string
module Error :
sig
@@ -81,13 +88,13 @@
val has_sender : message -> string -> bool
val has_signature : message -> string -> bool
val get_type : message -> message_type
- val get_path : message -> string
- val get_interface : message -> string
- val get_member : message -> string
- val get_error_name : message -> string
- val get_destination : message -> string
- val get_sender : message -> string
- val get_signature : message -> string
+ val get_path : message -> string option
+ val get_interface : message -> string option
+ val get_member : message -> string option
+ val get_error_name : message -> string option
+ val get_destination : message -> string option
+ val get_sender : message -> string option
+ val get_signature : message -> string option
val get_serial : message -> int32
val get_reply_serial : message -> int32
val get_auto_start : message -> bool
@@ -100,9 +107,11 @@
sig
val send : bus -> message -> int32
val send_with_reply : bus -> message -> int -> pending_call
+ val send_with_reply_and_block : bus -> message -> int -> error -> message
val add_filter : bus -> (bus -> message -> bool) -> unit
val flush : bus -> unit
- val read_write : bus -> int -> unit
+ val read_write : bus -> int -> bool
+ val read_write_dispatch : bus -> int -> bool
val pop_message : bus -> message option
val get_fd : bus -> Unix.file_descr
end
Index: dbus_stubs.c
===================================================================
RCS file: /home/remote/rjones/cvsroot/redhat/ocaml_dbus/dbus_stubs.c,v
retrieving revision 1.1
diff -u -r1.1 dbus_stubs.c
--- dbus_stubs.c 9 Jan 2008 11:01:27 -0000 1.1
+++ dbus_stubs.c 9 Jan 2008 16:37:07 -0000
@@ -13,6 +13,8 @@
* Dbus binding
*/
+#include <stdio.h>
+#include <stdlib.h>
#include <string.h>
#include <dbus/dbus.h>
#include <caml/mlvalues.h>
@@ -39,9 +41,17 @@
};
static int __type_table[] = {
- DBUS_TYPE_BYTE, DBUS_TYPE_BOOLEAN,
- DBUS_TYPE_INT16, DBUS_TYPE_INT32, DBUS_TYPE_INT64,
- DBUS_TYPE_DOUBLE, DBUS_TYPE_STRING,
+ DBUS_TYPE_BYTE,
+ DBUS_TYPE_BOOLEAN,
+ DBUS_TYPE_INT16,
+ DBUS_TYPE_UINT16,
+ DBUS_TYPE_INT32,
+ DBUS_TYPE_UINT32,
+ DBUS_TYPE_INT64,
+ DBUS_TYPE_UINT64,
+ DBUS_TYPE_DOUBLE,
+ DBUS_TYPE_STRING,
+ DBUS_TYPE_OBJECT_PATH,
-1
};
@@ -233,7 +243,7 @@
{
CAMLparam2(bus, message);
CAMLlocal1(serial);
- unsigned int c_serial;
+ dbus_uint32_t c_serial;
dbus_connection_send(DBusConnection_val(bus), DBusMessage_val(message),
&c_serial);
@@ -261,31 +271,57 @@
CAMLreturn(pending);
}
+value stub_dbus_connection_send_with_reply_and_block (value bus, value message,
+ value timeout,
+ value error)
+{
+ CAMLparam4(bus, message, timeout, error);
+ CAMLlocal1(rmessage);
+ DBusMessage *c_rmessage;
+
+ c_rmessage =
+ dbus_connection_send_with_reply_and_block
+ (DBusConnection_val(bus),
+ DBusMessage_val(message),
+ Int_val (timeout),
+ DBusError_val(error));
+ if (!c_rmessage) {
+ caml_failwith("dbus_connection_send_with_reply_and_block");
+ }
+
+ voidstar_alloc(rmessage, c_rmessage, finalize_dbus_message);
+ CAMLreturn(rmessage);
+}
+
DBusHandlerResult add_filter_callback(DBusConnection *connection,
DBusMessage *message,
- void *userdata)
+ void *callbackp)
{
CAMLparam0();
- CAMLlocal2(conn, msg);
- int ret;
+ CAMLlocal3(conn, msg, ret);
+ int c_ret;
voidstar_alloc(conn, connection, finalize_dbus_connection);
voidstar_alloc(msg, message, finalize_dbus_message);
- ret = Bool_val(caml_callback2(*((value *) userdata),
- conn, msg));
+ ret = caml_callback2(*(value*)callbackp, conn, msg);
+ c_ret = Bool_val (ret);
- CAMLreturn ((ret)
- ? DBUS_HANDLER_RESULT_HANDLED
+ CAMLreturn (c_ret
+ ? DBUS_HANDLER_RESULT_HANDLED
: DBUS_HANDLER_RESULT_NOT_YET_HANDLED);
}
value stub_dbus_connection_add_filter(value bus, value callback)
{
CAMLparam2(bus, callback);
+ value *callbackp;
+
+ callbackp = malloc (sizeof (value));
+ *callbackp = callback;
+ caml_register_global_root(callbackp);
- caml_register_global_root(&callback);
dbus_connection_add_filter(DBusConnection_val(bus),
- add_filter_callback, &callback, NULL);
+ add_filter_callback, callbackp, NULL);
CAMLreturn(Val_unit);
}
@@ -300,8 +336,19 @@
value stub_dbus_connection_read_write(value bus, value timeout)
{
CAMLparam2(bus, timeout);
- dbus_connection_read_write(DBusConnection_val(bus), Int_val(timeout));
- CAMLreturn(Val_unit);
+ dbus_bool_t b;
+
+ b = dbus_connection_read_write(DBusConnection_val(bus), Int_val(timeout));
+ CAMLreturn(Val_bool (b));
+}
+
+value stub_dbus_connection_read_write_dispatch(value bus, value timeout)
+{
+ CAMLparam2(bus, timeout);
+ dbus_bool_t b;
+
+ b = dbus_connection_read_write_dispatch(DBusConnection_val(bus), Int_val(timeout));
+ CAMLreturn(Val_bool (b));
}
value stub_dbus_connection_pop_message(value bus)
@@ -425,11 +472,16 @@
value stub_dbus_message_get_##type (value message) \
{ \
CAMLparam1(message); \
- CAMLlocal1(v); \
+ CAMLlocal2(v,vopt); \
const char *c_v; \
+ vopt = Val_int (0); /* None */ \
c_v = dbus_message_get_##type (DBusMessage_val(message)); \
- v = caml_copy_string(c_v); \
- CAMLreturn(v); \
+ if (c_v) { \
+ v = caml_copy_string(c_v); \
+ vopt = caml_alloc_small (1, 0); \
+ Field (vopt, 0) = v; \
+ } \
+ CAMLreturn(vopt); \
} \
#define MESSAGE_SET_ACCESSOR(type) \
@@ -474,7 +526,7 @@
{
CAMLparam1(message);
CAMLlocal1(serial);
- int c_serial;
+ dbus_uint32_t c_serial;
c_serial = dbus_message_get_serial(DBusMessage_val(message));
serial = caml_copy_int32(c_serial);
@@ -485,7 +537,7 @@
{
CAMLparam1(message);
CAMLlocal1(serial);
- int c_serial;
+ dbus_uint32_t c_serial;
c_serial = dbus_message_get_reply_serial(DBusMessage_val(message));
serial = caml_copy_int32(c_serial);
@@ -623,7 +675,6 @@
break;
}
case DBUS_TYPE_UINT16:
- type = find_index_equal(DBUS_TYPE_INT16, __type_table);
case DBUS_TYPE_INT16: {
int i;
dbus_message_iter_get_basic(&args, &i);
@@ -633,7 +684,6 @@
break;
}
case DBUS_TYPE_UINT32:
- type = find_index_equal(DBUS_TYPE_INT32, __type_table);
case DBUS_TYPE_INT32: {
int i;
dbus_message_iter_get_basic(&args, &i);
@@ -643,7 +693,6 @@
break;
}
case DBUS_TYPE_UINT64:
- type = find_index_equal(DBUS_TYPE_INT64, __type_table);
case DBUS_TYPE_INT64: {
unsigned long long ld;
dbus_message_iter_get_basic(&args, &ld);
@@ -652,6 +701,7 @@
Field(r, 0) = v;
break;
}
+ case DBUS_TYPE_OBJECT_PATH:
case DBUS_TYPE_STRING: {
char *s;
dbus_message_iter_get_basic(&args, &s);
@@ -661,9 +711,15 @@
break;
}
case DBUS_TYPE_DOUBLE: {
+ double d;
+ dbus_message_iter_get_basic(&args, &d);
+ v = caml_copy_double(d);
+ r = caml_alloc_small(1, type);
+ Field(r, 0) = v;
+ break;
}
default:
- caml_failwith("unexpected type in message");
+ caml_failwith("unsupported type in message");
v = Val_unit;
break;
}
@@ -749,3 +805,17 @@
CAMLreturn(message);
}
+
+/*
+ * vim: set tabstop=8:
+ * vim: set shiftwidth=8:
+ * vim: set expandtab:
+ */
+/*
+ * Local variables:
+ * indent-tabs-mode: nil
+ * c-indent-level: 8
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
Index: example_avahi.ml
===================================================================
RCS file: example_avahi.ml
diff -N example_avahi.ml
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ example_avahi.ml 9 Jan 2008 16:37:07 -0000
@@ -0,0 +1,102 @@
+(* Browse the local network for ssh services using Avahi and D-Bus.
+ * There is *zero* documentation for this. I examined a lot of code
+ * to do this, and the following page was also very helpful:
+ * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html
+ * See also the DBus API reference:
+ * http://dbus.freedesktop.org/doc/dbus/api/html/index.html
+ * See also Dan Berrange's Perl bindings:
+ * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/
+ *
+ * By Richard W.M. Jones <rich@annexia.org> or <rjones@redhat.com>.
+ * PUBLIC DOMAIN example code.
+ *)
+
+open Printf
+open DBus
+
+let rec print_msg msg =
+ (match Message.get_type msg with
+ | Message.Invalid ->
+ printf "Invalid";
+ | Message.Method_call ->
+ printf "Method_call";
+ | Message.Method_return ->
+ printf "Method_return";
+ | Message.Error ->
+ printf "Error";
+ | Message.Signal ->
+ printf "Signal");
+
+ let print_opt f name =
+ match f msg with
+ | None -> ()
+ | Some value -> printf " %s=%S" name value
+ in
+ print_opt Message.get_member "member";
+ print_opt Message.get_path "path";
+ print_opt Message.get_interface "interface";
+ print_opt Message.get_sender "sender";
+
+ let fields = Message.get msg in
+ printf "(";
+ print_fields fields;
+ printf ")\n%!";
+
+and print_fields fields =
+ printf "%s" (string_of_ty_list fields)
+
+(* Perform a synchronous call to an object method. *)
+let call_method ~bus ~err ~name ~path ~interface ~methd args =
+ (* Create the method_call message. *)
+ let msg = Message.new_method_call name path interface methd in
+ Message.append msg args;
+ (* Send the message, get reply. *)
+ let r = Connection.send_with_reply_and_block bus msg (-1) err in
+ Message.get r
+
+let () =
+ let err = Error.init () in
+ let bus = Bus.get Bus.System err in
+ if Error.is_set err then failwith "error set after getting System bus";
+
+ (* Create a new ServiceBrowser object which emits a signal whenever
+ * a new network service of the type specified is found on the network.
+ *)
+ let r =
+ call_method ~bus ~err
+ ~name:"org.freedesktop.Avahi"
+ ~path:"/"
+ ~interface:"org.freedesktop.Avahi.Server"
+ ~methd:"ServiceBrowserNew"
+ [
+ Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *)
+ Int32 0_l; (* 0=IPv4, 1=IPv6 *)
+ String "_ssh._tcp"; (* service type *)
+ String ""; (* XXX call GetDomainName() *)
+ UInt32 0_l; (* flags *)
+ ] in
+ let path =
+ match r with
+ | [ ObjectPath path ] -> path
+ | _ -> failwith "unexpected return value" in
+
+ eprintf "ServiceBrowser path = %S\n%!" path;
+
+ (* Register a callback to accept the signals. *)
+ Connection.add_filter bus (
+ fun bus msg ->
+ if Message.get_type msg = Message.Signal then (
+ print_msg msg;
+ );
+ true
+ );
+
+ (* Add a match rule so we see these signals. *)
+ Bus.add_match bus
+ ("type='signal',sender='org.freedesktop.Avahi.ServiceBrowser',path='" ^
+ path ^ "',member='ItemNew'")
+ err;
+
+ (* Wait for incoming signals. *)
+ while Connection.read_write_dispatch bus (-1) do ()
+ done
Index: test.ml
===================================================================
RCS file: /home/remote/rjones/cvsroot/redhat/ocaml_dbus/test.ml,v
retrieving revision 1.1
diff -u -r1.1 test.ml
--- test.ml 9 Jan 2008 11:01:27 -0000 1.1
+++ test.ml 9 Jan 2008 16:37:07 -0000
@@ -32,10 +32,9 @@
exit 1
);
- while true
+ while DBus.Connection.read_write bus 0
do
- DBus.Connection.read_write bus 0;
- let msg = DBus.Connection.pop_message bus in
+ let msg = DBus.Connection.pop_message bus in
match msg with
| None -> Unix.sleep 1; ()
| Some msg ->
Reply to: