(* $Id: rpc_util.ml 2195 2015-01-01 12:23:39Z gerd $ *)
open Printf
type verbosity =
[ `Name_only | `Name_abbrev_args | `Name_full_args ]
module StrMap = Map.Make(String)
(* The map functions are like those in Netxdr, but the type is a
xdr_type_term, not an xdr_type
*)
let rec get_enum t =
match t with
| Netxdr.X_enum enum -> enum
| Netxdr.X_direct(t1,_,_,_) -> get_enum t1
| _ -> failwith "Rpc_util.get_enum"
let fail_map_xv_enum_fast () =
failwith "Rpc_util.map_xv_enum_fast"
let map_xv_enum_fast t v =
match t with
| Netxdr.X_enum l ->
let l = Array.of_list l in
let m = Array.length l in
( match v with
| Netxdr.XV_enum_fast k ->
if k >= 0 && k < m then
snd(l.(k))
else
fail_map_xv_enum_fast()
| Netxdr.XV_enum name ->
let k = ref 0 in
while !k < m && (fst l.( !k ) <> name) do
incr k
done;
if !k >= m then
fail_map_xv_enum_fast();
snd(l.( !k ))
| _ ->
fail_map_xv_enum_fast()
)
| _ ->
fail_map_xv_enum_fast()
let fail_map_xv_struct_fast () =
failwith "Rpc_util.map_xv_struct_fast"
let map_xv_struct_fast t v =
match t with
| Netxdr.X_struct decl ->
let decl = Array.of_list decl in
let m = Array.length decl in
( match v with
| Netxdr.XV_struct_fast x ->
let k = Array.length x in
if k = m then
x
else
fail_map_xv_struct_fast()
| Netxdr.XV_struct l ->
( try
Array.map
(fun (name,y) -> List.assoc name l)
decl
with
Not_found -> fail_map_xv_struct_fast()
)
| _ ->
fail_map_xv_struct_fast()
)
| _ ->
fail_map_xv_struct_fast()
let fail_map_xv_union_over_enum_fast () =
failwith "Rpc_util.map_xv_struct_fast"
let map_xv_union_over_enum_fast t v =
match t with
| Netxdr.X_union_over_enum(enum_t, u, u_dfl ) ->
let e = Array.of_list (get_enum enum_t) in
let u = Array.of_list u in
let m = Array.length e in
assert( m = Array.length u );
( match v with
| Netxdr.XV_union_over_enum_fast(k, x) ->
if k >= 0 && k < m then
(k, (snd e.(k)), x)
else
fail_map_xv_union_over_enum_fast()
| Netxdr.XV_union_over_enum(name, x) ->
let k = ref 0 in
while !k < m && fst(e.( !k )) <> name do
incr k
done;
if !k >= m then
fail_map_xv_union_over_enum_fast();
(!k, (snd e.(!k)), x)
| _ ->
fail_map_xv_union_over_enum_fast()
)
| _ ->
fail_map_xv_union_over_enum_fast()
let string_of_opaque s l =
let b = Buffer.create 32 in
for k = 0 to l - 1 do
Buffer.add_string b (sprintf "%02x" (Char.code s.[k]))
done;
Buffer.contents b
let string_of_struct print_elem t v =
let tl =
match t with
| Netxdr.X_struct tl -> Array.of_list tl
| _ -> assert false in
let vl = map_xv_struct_fast t v in
"{" ^
String.concat ";"
(Array.to_list
(Array.mapi
(fun k (elem_name, elem_t) ->
let elem_v = vl.(k) in
sprintf "%s=%s" elem_name (print_elem elem_t elem_v)
)
tl
)
) ^ "}"
let string_of_array print_elem t v =
let elem_t =
match t with
| Netxdr.X_array_fixed(u,_)
| Netxdr.X_array(u,_) ->
u
| _ ->
assert false in
let vl =
Netxdr.dest_xv_array v in
"[" ^
String.concat ";"
(Array.to_list
(Array.map
(fun elem_v -> print_elem elem_t elem_v)
vl)) ^ "]"
let string_of_union print_elem t v =
let elem_t, elem_v, case =
match t with
| Netxdr.X_union_over_int(l, default) ->
let (n, elem_v) = Netxdr.dest_xv_union_over_int v in
let elem_t =
try List.assoc n l
with Not_found ->
( match default with
| None -> assert false
| Some d -> d
) in
(elem_t, elem_v, sprintf "%ld" (Netnumber.int32_of_int4 n))
| Netxdr.X_union_over_uint(l, default) ->
let (n, elem_v) = Netxdr.dest_xv_union_over_uint v in
let elem_t =
try List.assoc n l
with Not_found ->
( match default with
| None -> assert false
| Some d -> d
) in
(elem_t, elem_v, sprintf "%lu" (Netnumber.logical_int32_of_uint4 n))
| Netxdr.X_union_over_enum(enum_t, l, default) ->
let (k,_,elem_v) = map_xv_union_over_enum_fast t v in
let enum = get_enum enum_t in
let case, _ = List.nth enum k in
let elem_t =
try List.assoc case l
with Not_found ->
( match default with
| None -> assert false
| Some d -> d
) in
(elem_t, elem_v, case)
| _ -> assert false
in
sprintf
"union<case=%s %s>"
case
(print_elem elem_t elem_v)
let rec string_of_abbrev_arg t v =
match t with
| Netxdr.X_int
| Netxdr.X_uint
| Netxdr.X_hyper
| Netxdr.X_uhyper
| Netxdr.X_enum _
| Netxdr.X_float
| Netxdr.X_double
| Netxdr.X_void ->
string_of_full_arg t v
| Netxdr.X_opaque_fixed _
| Netxdr.X_opaque _ ->
let s = Netxdr.dest_xv_opaque v in
let l = min 16 (String.length s) in
let suffix = if l < String.length s then "..." else "" in
string_of_opaque s l ^ suffix
| Netxdr.X_string _ ->
let s = Netxdr.dest_xv_string v in
let l = min 16 (String.length s) in
let suffix = if l < String.length s then "..." else "" in
"\"" ^ (String.escaped (String.sub s 0 l)) ^ "\"" ^ suffix
| Netxdr.X_mstring (_,_) ->
let ms = Netxdr.dest_xv_mstring v in
let (s,p) = ms#as_string in
let l = min 16 ms#length in
let suffix = if l < ms#length then "..." else "" in
"\"" ^ (String.escaped (String.sub s p l)) ^ "\"" ^ suffix
| Netxdr.X_array_fixed _
| Netxdr.X_array _ ->
let a = Netxdr.dest_xv_array v in
"array<" ^ string_of_int (Array.length a) ^ ">"
| Netxdr.X_struct _ ->
"struct"
| Netxdr.X_union_over_int(_,_) ->
let (n,_) = Netxdr.dest_xv_union_over_int v in
sprintf "union<case=%ld>" (Netnumber.int32_of_int4 n)
| Netxdr.X_union_over_uint(_,_) ->
let (n,_) = Netxdr.dest_xv_union_over_uint v in
sprintf "union<case=%lu>" (Netnumber.logical_int32_of_uint4 n)
| Netxdr.X_union_over_enum(enum_t,_,_) ->
let e = get_enum enum_t in
let (k,_,_) = map_xv_union_over_enum_fast t v in
let (n,_) = List.nth e k in
sprintf "union<case=%s>" n
| Netxdr.X_direct(t1, _,_,_) ->
string_of_abbrev_arg t1 v
| Netxdr.X_refer _
| Netxdr.X_type _
| Netxdr.X_param _ ->
assert false
| Netxdr.X_rec(_,t') ->
string_of_abbrev_arg t' v
and string_of_rec_arg recdefs t v =
match t with
| Netxdr.X_int ->
sprintf "%ld"
(Netnumber.int32_of_int4 (Netxdr.dest_xv_int v))
| Netxdr.X_uint ->
sprintf "%lu"
(Netnumber.logical_int32_of_uint4 (Netxdr.dest_xv_uint v))
| Netxdr.X_hyper ->
sprintf "%Ld"
(Netnumber.int64_of_int8 (Netxdr.dest_xv_hyper v))
| Netxdr.X_uhyper ->
sprintf "%Lu"
(Netnumber.logical_int64_of_uint8 (Netxdr.dest_xv_uhyper v))
| Netxdr.X_enum enum ->
( match v with
| Netxdr.XV_enum case ->
case
| Netxdr.XV_enum_fast n ->
fst(List.nth enum n)
| _ -> assert false
)
| Netxdr.X_float ->
string_of_float
(Netnumber.float_of_fp4 (Netxdr.dest_xv_float v))
| Netxdr.X_double ->
string_of_float
(Netnumber.float_of_fp8 (Netxdr.dest_xv_double v))
| Netxdr.X_opaque_fixed _
| Netxdr.X_opaque _ ->
let s = Netxdr.dest_xv_opaque v in
string_of_opaque s (String.length s)
| Netxdr.X_string _ ->
let s = Netxdr.dest_xv_string v in
"\"" ^ String.escaped s ^ "\""
| Netxdr.X_mstring(_, _) ->
let ms = Netxdr.dest_xv_mstring v in
let (s,p) = ms#as_string in
"\"" ^ String.escaped (String.sub s p (ms#length-p)) ^ "\""
| Netxdr.X_array_fixed _
| Netxdr.X_array _ ->
string_of_array
(string_of_rec_arg recdefs)
t
v
| Netxdr.X_struct _ ->
string_of_struct
(string_of_rec_arg recdefs)
t
v
| Netxdr.X_union_over_int _
| Netxdr.X_union_over_uint _
| Netxdr.X_union_over_enum _ ->
string_of_union
(string_of_rec_arg recdefs)
t
v
| Netxdr.X_void ->
"void"
| Netxdr.X_rec (n, u) ->
let recdefs' = StrMap.add n u recdefs in
string_of_rec_arg recdefs' u v
| Netxdr.X_refer n ->
let u =
try StrMap.find n recdefs
with Not_found -> assert false in
string_of_rec_arg recdefs u v
| Netxdr.X_direct(t1, _, _, _) ->
string_of_rec_arg recdefs t1 v
| Netxdr.X_type _
| Netxdr.X_param _ ->
assert false
and string_of_full_arg t v =
string_of_rec_arg StrMap.empty t v
let rec string_of_abbrev_args t v =
match t with
| Netxdr.X_void ->
""
| Netxdr.X_struct _ ->
string_of_struct
string_of_abbrev_arg
t
v
| Netxdr.X_direct(t1,_,_,_) ->
string_of_abbrev_args t1 v
| _ ->
string_of_abbrev_arg t v
let rec string_of_full_args t v =
match t with
| Netxdr.X_void ->
""
| Netxdr.X_struct _ ->
string_of_struct
string_of_full_arg
t
v
| Netxdr.X_direct(t1,_,_,_) ->
string_of_full_args t1 v
| _ ->
string_of_full_arg t v
let string_of_request v prog procname args =
try
let prognr = Rpc_program.program_number prog in
let versnr = Rpc_program.version_number prog in
let (procnr, in_t, _) = Rpc_program.signature prog procname in
let in_t = Netxdr.xdr_type_term in_t in
let s_args =
match v with
| `Name_only -> ""
| `Name_abbrev_args -> string_of_abbrev_args in_t args
| `Name_full_args -> string_of_full_args in_t args in
sprintf
"%s[0x%lx,0x%lx,0x%lx](%s)"
procname
(Netnumber.logical_int32_of_uint4 prognr)
(Netnumber.logical_int32_of_uint4 versnr)
(Netnumber.logical_int32_of_uint4 procnr)
s_args
with
| e ->
sprintf "[Exception in string_of_request: %s]"
(Netexn.to_string e)
let string_of_response v prog procname rv =
try
let prognr = Rpc_program.program_number prog in
let versnr = Rpc_program.version_number prog in
let (procnr, _, out_t) = Rpc_program.signature prog procname in
let out_t = Netxdr.xdr_type_term out_t in
let s_rv =
match v with
| `Name_only -> ""
| `Name_abbrev_args -> string_of_abbrev_arg out_t rv
| `Name_full_args -> string_of_full_arg out_t rv in
sprintf
"%s[0x%lx,0x%lx,0x%lx] returns %s"
procname
(Netnumber.logical_int32_of_uint4 prognr)
(Netnumber.logical_int32_of_uint4 versnr)
(Netnumber.logical_int32_of_uint4 procnr)
s_rv
with
| e ->
sprintf "[Exception in string_of_response: %s]"
(Netexn.to_string e)
let string_of_value t xv =
string_of_full_arg t xv
let hex_dump_m m pos len =
let b = Buffer.create 100 in
for k = 0 to len - 1 do
let c = Bigarray.Array1.get m (pos+k) in
bprintf b "%02x " (Char.code c)
done;
Buffer.contents b
let hex_dump_s s pos len =
let b = Buffer.create 100 in
for k = 0 to len - 1 do
let c = s.[pos+k] in
bprintf b "%02x " (Char.code c)
done;
Buffer.contents b
