From fb793504d99d1da0c5a5f514f2bc84ba024217c3 Mon Sep 17 00:00:00 2001
From: Tomasz Wroblewski <tomasz.wroblewski@citrix.com>
Date: Tue, 12 Jan 2010 10:39:38 +0000
Subject: [PATCH] xenvm: add DBus introspection

---
 xenvm/xenvm.ml | 38 +++++++++++++++++++++++++++++++++++---
 1 file changed, 35 insertions(+), 3 deletions(-)

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index f8766cb..eb90616 100644
--- a/xenvm/xenvm.ml
+++ b/xenvm/xenvm.ml
@@ -708,6 +708,35 @@ let monitor_rpc_json socket state =
 		)
 	)
 
+let introspect state msg =
+	let header =
+		"<!DOCTYPE node PUBLIC \"-//freedesktop//DTD D-BUS Object Introspection 1.0//EN\" " ^
+		"\"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd\">\n"
+	in
+	let method_desc m =
+		"<method name=\"" ^ m ^ "\">"
+		^ "<arg name=\"params\" type=\"a{ss}\" direction=\"in\"/>"
+		^ "<arg name=\"rval\" type=\"s\" direction=\"out\"/>"
+		^ "</method>"
+	in
+	let methods =
+		let get_m (task, desc) = String.replace "-" "_" desc.Tasks.name in
+		List.map get_m Tasks.actions_table
+	in
+	let node = Printf.sprintf "org/xen/vm/%s" (String.replace "-" "_" state.vm_uuid) in
+	let intf = Printf.sprintf "org.xen.vm.uuid_%s" (String.replace "-" "_" state.vm_uuid) in
+	let body =
+		header
+		^ "<node name=\"" ^ node ^ "\">\n"
+		^ "<interface name=\"" ^ intf ^ "\">\n"
+		^ List.fold_left (fun acc m -> acc ^ (method_desc m) ^ "\n") "" methods
+		^ "</interface>"
+		^ "</node>"
+	in
+	let r = DBus.Message.new_method_return msg in
+	DBus.Message.append r [DBus.String body];
+	r
+
 let monitor_rpc_dbus state =
 	let use_session = state.vm_monitors.monitor_use_dbus_session in
 	let intf = Printf.sprintf "org.xen.vm.uuid_%s" (String.replace "-" "_" state.vm_uuid) in
@@ -764,8 +793,11 @@ let monitor_rpc_dbus state =
 		let params = DBus.Message.get msg in
 		let msg_method = match DBus.Message.get_member msg with None -> "missingmethod" | Some m -> m in
 		let msg_method = String.replace "_" "-" msg_method in
-		match params with
-		| [ DBus.Array DBus.Dicts ((_, _), msg_params) ] ->
+		let interface = match DBus.Message.get_interface msg with None -> "" | Some i -> i in
+		match interface, msg_method, params with
+		| "org.freedesktop.DBus.Introspectable", "Introspect", _ ->
+			  Some (introspect state msg)
+		| _, _, [ DBus.Array DBus.Dicts ((_, _), msg_params) ] ->
 			let params = List.map (fun (k, v) ->
 				match k, v with
 				| DBus.String key, DBus.String value -> key, value
@@ -777,7 +809,7 @@ let monitor_rpc_dbus state =
 				warn "dbus_monitor received exception: %s\n" (Printexc.to_string exn);
 				Some (DBus.Message.new_error msg DBus.ERR_FAILED "?")
 			)
-		| _ ->
+		| _, _, _ ->
 			let err_msg = DBus.Message.new_error msg DBus.ERR_INVALID_ARGS
 			              "expecting string method followed by dictionnary" in
 			Some (err_msg)
-- 
2.39.5