move xenvmlib to use jsonrpc instead of text

diff --git a/xenvm/Makefile b/xenvm/Makefile
index fbc022cf00b1f5e3fe73620a108069e254c99527..81616e2763524d1ee8023b2677347bc0cd549ff0 100644 (file)
--- a/xenvm/Makefile
+++ b/xenvm/Makefile
@@ -40,6 +40,8 @@ xenvm_LIBS = unix.cmxa threads.cmxa \
        -ccopt -L -ccopt $(TOPLEVEL)/xenops $(TOPLEVEL)/xenops/xenops.cmxa
 
 xenvm-cmd_LIBS = unix.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
 
 xenops_LIBS = unix.cmxa threads.cmxa \

diff --git a/xenvm/xenvm-cmd.ml b/xenvm/xenvm-cmd.ml
index fd8e7fb88fccf431fac26fe45c34fb7d18464d62..9d87b04b03c875c0ea7edf4b892c60bbb3e4c994 100644 (file)
--- a/xenvm/xenvm-cmd.ml
+++ b/xenvm/xenvm-cmd.ml
@@ -16,6 +16,14 @@
 
 open Printf
 
+let kvpair s =
+       match Stringext.String.split ~limit:2 '=' s with
+       | k :: v :: [] -> Some (k, v)
+       | _            -> None
+
+let valid_kvpairs args =
+       List.rev (List.fold_left (fun acc x -> match kvpair x with Some x -> x :: acc | None -> acc) [] args)
+
 let _ =
        if Array.length Sys.argv < 3 then (
                eprintf "usage: %s <uuid> <cmd> [cmd args]\n" Sys.argv.(0);
@@ -23,10 +31,15 @@ let _ =
        );
        let uuid = Sys.argv.(1) in
 
-       let cmds = Array.sub Sys.argv 2 (Array.length Sys.argv - 2) in
-       let s = (String.concat " " (Array.to_list cmds)) in
+       let cmds = Array.to_list (Array.sub Sys.argv 2 (Array.length Sys.argv - 2)) in
+       let query =
+               match cmds with
+               | cmd :: args -> cmd, valid_kvpairs args
+               | []          -> eprintf "error: missing query\n"; exit 1
+               in
+
        try
-               match Xenvmlib.request ~timeout:60.0 uuid s with
+               match Xenvmlib.request ~timeout:60.0 uuid query with
                | Xenvmlib.Ok          -> ()
                | Xenvmlib.Timeout     -> eprintf "timeout\n"; exit 1
                | Xenvmlib.Error error -> eprintf "error: %s\n" error; exit 1

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index d06a7ba39260345f56df42199e034c1692bb06d0..46ea23f8536490af2da8501223f759344c10f9ef 100644 (file)
--- a/xenvm/xenvm.ml
+++ b/xenvm/xenvm.ml
@@ -108,7 +108,7 @@ let with_xcs f =
 let check_vm uuid =
        let is_running =
                try
-                       let reply = Xenvmlib.request ~timeout:10. (Uuid.to_string uuid) "status" in
+                       let reply = Xenvmlib.request ~timeout:10. (Uuid.to_string uuid) ("status", []) in
                        begin match reply with
                        | Xenvmlib.Msg _ -> ()
                        | _              -> ()

diff --git a/xenvm/xenvmlib.ml b/xenvm/xenvmlib.ml
index f258ebec568e613cc99472ebefdadbb9519fad18..8ace27bbbaab873ad330f7808ef346d06004d595 100644 (file)
--- a/xenvm/xenvmlib.ml
+++ b/xenvm/xenvmlib.ml
@@ -14,31 +14,16 @@
  * GNU Lesser General Public License for more details.
  *)
 
-open Stringext
+open Pervasiveext
+(*open Stringext*)
 
+type query = (string * ((string * string) list))
 type answer = Ok | Error of string | Msg of string | Unknown of string | Timeout
 
-let string_of_answer answer =
-       match answer with
-       | Ok        -> "CMD_OK"
-       | Timeout   -> "CMD_TIMEOUT"
-       | Error s   -> "CMD_ERROR " ^ s
-       | Msg s     -> "CMD_MSG " ^ s
-       | Unknown s -> s
-
-let answer_of_string s =
-       if s = "CMD_OK" then
-               Ok
-       else if s = "CMD_TIMEOUT" then
-               Timeout
-       else if String.startswith "CMD_ERROR " s then
-               Error (String.sub s 10 (String.length s - 10))
-       else if String.startswith "CMD_MSG " s then
-               Msg (String.sub s 8 (String.length s - 8))
-       else
-               Unknown s
-
+exception Partial_Write
+exception Partial_Read
 exception Write_timeout
+exception Read_timeout
 exception Connect_refused of string
 
 let path_of_socket id =
@@ -67,12 +52,14 @@ let dowrite ?(timeout=(-1.0)) fd buf =
                        raise Write_timeout;
 
                let wr = Unix.write fd buf (len - !left) (!left) in
+               if wr = 0 then
+                       raise Partial_Write;
                left := !left - wr
        done
 
-let doread ?(timeout=(-1.0)) fd =
-       let b = Buffer.create 128 in
-       let buf = String.create 128 in
+let doread_eof ?(timeout=(-1.0)) fd =
+       let buf = Buffer.create 1024 in
+       let s = String.create 1024 in
        let quit = ref false in
        while not !quit
        do
@@ -80,29 +67,81 @@ let doread ?(timeout=(-1.0)) fd =
                        try Unix.select [ fd ] [] [] timeout
                        with _ -> [], [], []
                        in
-               if not (List.mem fd r) then (
-                       Buffer.clear b;
-                       Buffer.add_string b (string_of_answer Timeout);
-                       quit := true;
-               ) else (
-                       let rd = Unix.read fd buf 0 128 in
-                       if rd = 0 then
-                               quit := true
-                       else
-                               Buffer.add_substring b buf 0 rd
+               if not (List.mem fd r) then
+                       raise Read_timeout;
+
+               let rd = Unix.read fd s 0 (String.length s) in
+               if rd = 0 then
+                       quit := true
+               else (
+                       Buffer.add_substring buf s 0 rd
                )
        done;
-       Buffer.contents b
+       Buffer.contents buf
 
-(** request s from a running xenvm identified by id (uuid or name) *)
-let request ?timeout id s =
-       let fd = connect id in
+let doread ?(timeout=(-1.0)) fd len =
+       let buf = String.create len in
+       let offset = ref 0 in
+       let left = ref len in
+       while !left > 0
+       do
+               let r, _, _ =
+                       try Unix.select [ fd ] [] [] timeout
+                       with _ -> [], [], []
+                       in
+               if not (List.mem fd r) then
+                       raise Read_timeout;
+
+               let rd = Unix.read fd buf !offset !left in
+               if rd = 0 then
+                       raise Partial_Read;
+               offset := !offset + rd;
+               left := !left - rd;
+       done;
+       buf
+
+let send_query ?timeout fd query =
+       let query_name, query_params = query in
+       let jparams = Json.Object (Array.of_list (List.map (fun (k, v) -> k, Json.String v) query_params)) in
+       let req = {
+               Jsonrpc.request_id = Some (Json.Int 1L);
+               Jsonrpc.method_name = query_name;
+               Jsonrpc.params = jparams;
+       } in
+       let s = Jsonrpc.request_to_string req in
+       let len = String.length s in
+       let header = String.create 4 in
 
-       dowrite ?timeout fd (s ^ "!");
-       let answer = doread ?timeout fd in
-       Unix.close fd;
+       (* make header *)
+       let char_of_int len shift = Char.chr ((len lsr shift) land 0xff) in
+       header.[0] <- char_of_int len 24;
+       header.[1] <- char_of_int len 16;
+       header.[2] <- char_of_int len 8;
+       header.[3] <- char_of_int len 0;
 
-       answer_of_string answer
+       dowrite ?timeout fd header;
+       dowrite ?timeout fd s;
+       ()
+
+let recv_resp ?timeout fd =
+       let s = doread_eof ?timeout fd in
+       let jsonrpc = Jsonrpc.response_of_string s in
+       match jsonrpc.Jsonrpc.response with
+       | Jsonrpc.Result r -> (
+               match r with
+               | Json.Null     -> Ok
+               | Json.String m -> Msg m
+               | _             -> Error "unknown return value in success"
+               )
+       | Jsonrpc.Error (code, message, optdata) ->
+               Error message
+
+let request ?timeout id query =
+       let fd = connect id in
+       finally (fun () ->
+               send_query ?timeout fd query;
+               recv_resp ?timeout fd
+       ) (fun () -> Unix.close fd)
 
 let code_ping = 0x0000
 let code_hup = 0x0001