add support for doing client xenvm queries over dBus

diff --git a/xenvm/Makefile b/xenvm/Makefile
index ae6e3a28fa4efac0574df86b1602197ffb6e77db..45a275f2fda8016fe2838f2604b3ec7df6dd1eea 100644 (file)
--- a/xenvm/Makefile
+++ b/xenvm/Makefile
@@ -39,7 +39,7 @@ xenvm_LIBS = unix.cmxa dBus.cmxa threads.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/libs/base64 $(TOPLEVEL)/libs/base64/base64.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/xenops $(TOPLEVEL)/xenops/xenops.cmxa
 
-xenvm-cmd_LIBS = unix.cmxa threads.cmxa \
+xenvm-cmd_LIBS = unix.cmxa dBus.cmxa threads.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/libs/json $(TOPLEVEL)/libs/json/json.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/libs/jsonrpc $(TOPLEVEL)/libs/jsonrpc/jsonrpc.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/libs/stdext $(TOPLEVEL)/libs/stdext/stdext.cmxa

diff --git a/xenvm/xenvmlib.ml b/xenvm/xenvmlib.ml
index 282edec017544794dc2fc4e4f38fee5d5d5f202a..20802620b52589b4fd40741b024d1e932f3765e0 100644 (file)
--- a/xenvm/xenvmlib.ml
+++ b/xenvm/xenvmlib.ml
@@ -15,7 +15,7 @@
  *)
 
 open Pervasiveext
-(*open Stringext*)
+open Stringext
 
 type query = (string * ((string * string) list))
 type answer = Ok | Error of string | Msg of string | Unknown of string | Timeout
@@ -26,6 +26,8 @@ exception Write_timeout
 exception Read_timeout
 exception Connect_refused of string
 
+module Socket = struct
+
 let path_of_socket id =
        let dir = try Sys.getenv "XENVM_SOCKET_DIR" with Not_found -> "/var/lib/xenvm" in
        Printf.sprintf "%s/vm-%s" dir id
@@ -143,6 +145,36 @@ let request ?timeout id query =
                send_query ?timeout fd query;
                recv_resp ?timeout fd
        ) (fun () -> Unix.close fd)
+end
+
+module Bus = struct
+
+let request ?timeout id query =
+       let using_session = try bool_of_string (Sys.getenv "XENVMLIB_DBUS_SESSION") with _ -> false in
+       let bus = DBus.Bus.get (if using_session then DBus.Bus.Session else DBus.Bus.System) in
+       let timeout = match timeout with None -> 0 | Some t -> int_of_float (t *. 1000.) in
+
+       let dest = "org.xen.vm" in
+       let intf = Printf.sprintf "org.xen.vm.%s" (String.replace "-" "_" id) in
+
+       let method_name, params = query in
+       let msg = DBus.Message.new_method_call dest "/" intf method_name in
+       DBus.Message.append msg [];
+       let reply = DBus.Connection.send_with_reply_and_block bus msg timeout in
+       let args = DBus.Message.get reply in
+       match DBus.Message.get_type reply, args with
+       | DBus.Message.Error, [ DBus.String s ] -> Error s
+       | DBus.Message.Error, _                 -> Error "error with unexpected arguments"
+       | DBus.Message.Method_return, []        -> Ok
+       | DBus.Message.Method_return, [ DBus.String s ] -> Msg s
+       | _                          -> assert false
+
+end
+
+let request ?(using_socket=false) ?timeout id query =
+       if using_socket
+       then Socket.request ?timeout id query
+       else Bus.request ?timeout id query
 
 let code_ping = 0x0000
 let code_hup = 0x0001