From e62dfa03bbaff0a787964abf7583700e9e0e0907 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Tue, 12 May 2009 16:14:15 +0100 Subject: [PATCH] move xenvmlib to use jsonrpc instead of text --- xenvm/Makefile | 2 + xenvm/xenvm-cmd.ml | 19 +++++-- xenvm/xenvm.ml | 2 +- xenvm/xenvmlib.ml | 123 +++++++++++++++++++++++++++++---------------- 4 files changed, 100 insertions(+), 46 deletions(-) diff --git a/xenvm/Makefile b/xenvm/Makefile index fbc022c..81616e2 100644 --- 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 fd8e7fb..9d87b04 100644 --- 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 [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 d06a7ba..46ea23f 100644 --- 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 f258ebe..8ace27b 100644 --- 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 -- 2.39.5