xenvm: add DBus introspection

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index f8766cb40671f9848c716a9e9549fa9675f5f746..eb90616bbd377ca6a8c2fee7c87998ccccdc153e 100644 (file)
--- 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)