From: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
Date: Mon, 17 Aug 2009 09:51:15 +0000 (+0100)
Subject: add support for doing client xenvm queries over dBus
X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=ea71c2df9dc58bbee3ba31b477ef68726a76f70c;p=xenclient%2Ftoolstack.git

add support for doing client xenvm queries over dBus
---

diff --git a/xenvm/Makefile b/xenvm/Makefile
index ae6e3a2..45a275f 100644
--- 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 282edec..2080262 100644
--- 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