make the dbus monitor execute tasks

note: that until the queue process is done, all actions are executed
in the context of the monitor thread, so will blocks all others operations.

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index cd4a127d3004fe7029595f18837a76935837c8a9..f3f1625ce5dc076334cc03ed040eba2488ee1c8d 100644 (file)
--- a/xenvm/xenvm.ml
+++ b/xenvm/xenvm.ml
@@ -649,6 +649,69 @@ let monitor_rpc_json socket state =
        )
 
 let monitor_rpc_dbus state =
+       let use_session = false in
+       let match_s = sprintf "type='method',interface='org.xen.vm.%s'" (String.replace "-" "_" state.vm_uuid) in
+       let bus = DBus.Bus.get (if use_session then DBus.Bus.Session else DBus.Bus.System) in
+       DBus.Bus.add_match bus match_s false;
+       DBus.Connection.flush bus;
+
+       let calltask msg msg_method params =
+               let xenvmlib_to_dbus rep =
+                       match rep with
+                       | Xenvmlib.Ok        -> Some (DBus.Message.new_method_return msg)
+                       | Xenvmlib.Msg s     ->
+                               let rmsg = DBus.Message.new_method_return msg in
+                               DBus.Message.append rmsg [ DBus.String s ];
+                               Some rmsg
+                       | Xenvmlib.Error err -> Some (DBus.Message.new_error msg DBus.ERR_FAILED err)
+                       | _                  -> None
+                       in
+               (* if the tasks need to be threaded like start,reboot,.. we returns
+                 none to the caller and create a thread that is going to populate a queue
+                 with the return message when ready *)
+               let t = try Some (Tasks.find msg_method) with exn -> None in
+               match t with
+               | None   -> Some (DBus.Message.new_error msg DBus.ERR_SERVICE_UNKNOWN "no rpc")
+               | Some (act, task_descr) ->
+                       let taskargs = List.map (fun (k, v) -> (k, Tasks.ValString v)) params in
+                       if task_descr.Tasks.need_threading then (
+                               thread_create (fun () ->
+                                       let rep = do_task state (act, taskargs) in
+                                       let rep = xenvmlib_to_dbus rep in
+                                       ignore rep (* FIXME put in the queue *)
+                               ) ();
+                               None
+                       ) else
+                               xenvmlib_to_dbus (do_task state (act, taskargs))
+               in
+
+       let process_message msg =
+               let params = DBus.Message.get msg in
+               match params with
+               | [ DBus.String msg_method; 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
+                               | DBus.String key, DBus.Variant (DBus.String value) -> key, value
+                               | _ -> assert false (* replace by sensible error *)
+                       ) msg_params in
+                       calltask msg msg_method params
+               | _ ->
+                       let err_msg = DBus.Message.new_error msg DBus.ERR_INVALID_ARGS
+                                     "expecting string method followed by dictionnary" in
+                       Some (err_msg)
+               in
+
+       while not state.vm_monitors.monitor_dbus_quit do
+               (* check for outputing work *)
+               DBus.Connection.read_write bus 200;
+               let reply =
+                       match DBus.Connection.pop_message bus with
+                       | None     -> None
+                       | Some msg -> process_message msg
+                       in
+               maybe (fun reply -> DBus.Connection.send bus reply; DBus.Connection.flush bus) reply
+       done;
        ()
 
 (*