xenvm: repair the rpc interface that wasn't accepting anymore message correctly

diff --git a/xenvm/tasks.ml b/xenvm/tasks.ml
index 6918575088962650b99d39549a8bc1af2e52486c..827f58b74e9288fb96db698015f35feba4acfdf0 100644 (file)
--- a/xenvm/tasks.ml
+++ b/xenvm/tasks.ml
@@ -89,6 +89,11 @@ let actions_table = [
 
 exception Invalid_type_registered of string
 exception Argument_not_found of string
+exception Task_not_found of string
+
+let find name =
+       try List.find (fun p -> (snd p).name = name) actions_table
+       with Not_found -> raise (Task_not_found name)
 
 let args_assoc name args =
        try List.assoc name args
@@ -101,8 +106,9 @@ let args_get_string args name =
 
 let args_get_bool args name =
        match args_assoc name args with
-       | ValBool b -> b
-       | _         -> raise (Invalid_type_registered name)
+       | ValBool b   -> b
+       | ValString s -> try bool_of_string s with exn -> raise (Invalid_type_registered name)
+       | _           -> raise (Invalid_type_registered name)
 
 let args_get_liststring args name =
        match args_assoc name args with

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index 46ea23f8536490af2da8501223f759344c10f9ef..ceacf6e5479e96eebc888c723c323643f8e86257 100644 (file)
--- a/xenvm/xenvm.ml
+++ b/xenvm/xenvm.ml
@@ -460,44 +460,64 @@ let monitor_rpc socket state =
        let quit = ref false in
        let connections = ref [] in
 
+       let reply_error con error =
+               let s = Jsonrpc.response_to_string error in
+               thread_create (fun () ->
+                       let len = String.length s in
+                       let w = Unix.write con.con_fd s 0 len in
+                       ignore w;
+                       con_close con;
+               ) ();
+               in
+       let do_rpc con rpc task taskdescr =
+               let params = match rpc.Jsonrpc.params with
+               | Json.Null -> []
+               | Json.Object a ->
+                       Array.to_list (
+                               Array.map (fun (k, v) ->
+                                       match v with Json.String s -> k, Tasks.ValString s | _ -> failwith "unexpected"
+                               ) a
+                       )
+               | _ -> []
+                       in
+               thread_create (fun () ->
+                       let reply_id = match rpc.Jsonrpc.request_id with Some id -> id | None -> Json.Int 0L in
+                       let reply =
+                               try
+                                       let r = do_task quit state (task, params) in
+                                       match r with
+                                       | Xenvmlib.Ok -> Jsonrpc.response_make_success reply_id Json.Null
+                                       | Xenvmlib.Msg msg -> Jsonrpc.response_make_success reply_id (Json.String msg)
+                                       | _ -> assert false
+                               with exn ->
+                                       let err = string_of_exn exn in
+                                       Jsonrpc.response_make_error reply_id (Jsonrpc.code_error_invalid_params) err None
+                               in
+                       let s = Jsonrpc.response_to_string reply in
+                       let len = String.length s in
+                       let w = Unix.write con.con_fd s 0 len in
+                       ignore w;
+                       con_close con;
+               ) ()
+               in
        let connection_do_task con =
                let rpc =
                        try Right (Jsonrpc.request_of_string (Buffer.contents con.con_buf))
                        with exn -> Left (string_of_exn exn)
                        in
                match rpc with
-               | Right rpc ->
-                       thread_create (fun () ->
-                               (* FIXME do proper parsing here *)
-                               let task = Tasks.Quit in
-                               let params = [] in
-                               let reply_id = match rpc.Jsonrpc.request_id with Some id -> id | None -> Json.Int 0L in
-                               let reply =
-                                       try
-                                               let r = do_task quit state (task, params) in
-                                               match r with
-                                               | Xenvmlib.Ok -> Jsonrpc.response_make_success reply_id Json.Null
-                                               | Xenvmlib.Msg msg -> Jsonrpc.response_make_success reply_id (Json.String msg)
-                                               | _ -> assert false
-                                       with exn ->
-                                               let err = string_of_exn exn in
-                                               Jsonrpc.response_make_error reply_id (Jsonrpc.code_error_invalid_params) err None
-                                       in
-                               let s = Jsonrpc.response_to_string reply in
-                               let len = String.length s in
-                               let w = Unix.write con.con_fd s 0 len in
-                               ignore w;
-                               con_close con;
-                       ) ()
+               | Right rpc -> (
+                       let t = try Some (Tasks.find rpc.Jsonrpc.method_name) with exn -> None in
+                       match t with
+                       | None -> 
+                               let error = Jsonrpc.response_make_error (Json.Int 0L) (Jsonrpc.code_error_invalid_params) "unknown RPC" None in
+                               reply_error con error
+                       | Some (act, task_descr) ->
+                               do_rpc con rpc act task_descr
+                       )
                | Left err  ->
                        let error = Jsonrpc.response_make_error (Json.Int 0L) (Jsonrpc.code_error_invalid_params) err None in
-                       let s = Jsonrpc.response_to_string error in
-                       thread_create (fun () ->
-                               let len = String.length s in
-                               let w = Unix.write con.con_fd s 0 len in
-                               ignore w;
-                               con_close con;
-                       ) ();
+                       reply_error con error
                in
        (* process a jsonrpc type of connection *)
        let connection_process con =