Lots of small changes, starts to become stable so include it in the build.
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
$(MAKE) -C log
$(MAKE) -C sha1
$(MAKE) -C xml-light2
-# $(MAKE) -C rpc-light
+ $(MAKE) -C rpc-light
allxen:
$(MAKE) -C mmap
$(MAKE) -C log install
$(MAKE) -C sha1 install
$(MAKE) -C xml-light2 install
-# $(MAKE) -C rpc-light install
+ $(MAKE) -C rpc-light install
installxen:
$(MAKE) -C mmap install
$(MAKE) -C log uninstall
$(MAKE) -C sha1 uninstall
$(MAKE) -C xml-light2 uninstall
-# $(MAKE) -C rpc-light uninstall
+ $(MAKE) -C rpc-light uninstall
uninstallxen:
$(MAKE) -C eventchn uninstall
make -C log clean
make -C sha1 clean
make -C xml-light2 clean
-# make -C rpc-light clean
+ make -C rpc-light clean
rm -f $(OUTPUT_API_PKG)
cleanxen:
--- /dev/null
+version = "0.1"
+description = "JSON-RPC marshalling/unmarshalling"
+archive(byte) = "jsonrpc.cma"
+archive(native) = "jsonrpc.cmxa"
version = "0.1"
description = "XML-RPC marshalling/unmarshalling"
-requires = "xml-light2"
+requires = "xmlm"
archive(byte) = "xmlrpc.cma"
archive(native) = "xmlrpc.cmxa"
OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
-OCAMLFLAGS = -annot
+OCAMLFLAGS = -annot -g
PACKS = xmlm
ICAMLP4=-I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv)
OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
-OCAMLFLAGS = -annot
+OCAMLFLAGS = -annot -g
-PACKS = xmlrpc
+PACKS = xmlrpc,jsonrpc
EXAMPLES = all_types
EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
$(OCAMLOPT) -linkpkg -package $(PACKS) -o $@ $<
%.cmx: %.ml
- $(OCAMLOPT) -package $(PACKS),rpc-light.syntax -syntax camlp4o -c -o $@ $<
+ $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS),rpc-light.syntax -syntax camlp4o -c -o $@ $<
+
+%_gen: %.ml
+ camlp4o $(shell ocamlfind query rpc-light.syntax -r -format "-I %d %a" -predicates syntax,preprocessor) $< -printer o > $@.ml
+ $(OCAMLOPT) -package $(PACKS) -c -o $@ $@.ml
clean:
rm -f *.cmx *.cmi *.cmo *.cmxa *.o $(EXECS)
\ No newline at end of file
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
+
type t = Foo of int | Bar of (int * float) with rpc
type x = {
f2: (string * string list) array;
f3: int32;
f4: int64;
+ f5: int;
+ f6: (unit * char) list;
+ progress: int array;
} with rpc
let _ =
let x1 = {
foo= Foo 3;
- bar= "foo";
+ bar= "ha ha";
gna=[1.; 2.; 3.; 4. ];
f2 = [| "hi",["hi"]; "hou",["hou";"hou"]; "foo", ["b";"a";"r"] |];
f1 = None;
f3 = Int32.max_int;
- f4 = Int64.max_int
+ f4 = Int64.max_int;
+ f5 = max_int;
+ f6 = [ (),'a' ; (),'b' ; (),'c'; (),'d' ; (),'e' ];
+ progress = [| 0; 1; 2; 3; 4; 5 |];
} in
- let str = Xmlrpc.to_string (rpc_of_x x1) in
- Printf.printf "String: %s\n\n" str;
- let x2 = x_of_rpc (Xmlrpc.of_string str) in
- Printf.printf "Result: %s\nx1=x2: %b\n\n" str (x1 = x2)
+
+ let rpc = rpc_of_x x1 in
+ let xml = Xmlrpc.to_string rpc in
+ let json = Jsonrpc.to_string rpc in
+
+ Printf.printf "xmlrpc: %s\n\n" xml;
+ Printf.printf "jsonrpc: %s\n\n" json;
+
+ let callback fields value = match (fields, value) with
+ | ["progress"], `Int i -> Printf.printf "Progress: %Ld\n" i
+ | _ -> ()
+ in
+ let x2 = x_of_rpc (Xmlrpc.of_string ~callback xml) in
+ let x3 = x_of_rpc (Jsonrpc.of_string json) in
+
+ Printf.printf "\nSanity check:\nx1=x2: %b\nx2=x3: %b\nx1=x3: %b\n\n" (x1 = x2) (x2 = x3) (x1 = x3)
+
(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- * Author Vincent Hanquez <firstname.lastname@citrix.com>
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
let rec to_fct t f =
match t with
- | Rpc.Int i -> f (Printf.sprintf "%Ld" i)
- | Rpc.Double r -> f (Printf.sprintf "%f" r)
- | Rpc.String s -> f (escape_string s)
- | Rpc.Bool b -> f (string_of_bool b)
- | Rpc.Nil -> f "null"
- | Rpc.Array a ->
+ | `Int i -> f (Printf.sprintf "%Ld" i)
+ | `Bool b -> f (string_of_bool b)
+ | `Float r -> f (Printf.sprintf "%f" r)
+ | `String s -> f (escape_string s)
+ | `None -> f "null"
+ | `List a ->
f "[";
list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a;
f "]";
- | Rpc.Struct a ->
+ | `Dict a ->
f "{";
- list_iter_between (fun (k, v) -> to_fct (Rpc.String k) f; f ": "; to_fct v f)
+ list_iter_between (fun (k, v) -> to_fct (`String k) f; f ": "; to_fct v f)
(fun () -> f ", ") a;
f "}"
| Expect_object_elem_colon
| Expect_comma_or_end
| Expect_object_key
- | Done of Rpc.t
+ | Done of Rpc.Val.t
type int_value =
- | IObject of (string * Rpc.t) list
- | IObject_needs_key of (string * Rpc.t) list
- | IObject_needs_value of (string * Rpc.t) list * string
- | IArray of Rpc.t list
+ | IObject of (string * Rpc.Val.t) list
+ | IObject_needs_key of (string * Rpc.Val.t) list
+ | IObject_needs_value of (string * Rpc.Val.t) list * string
+ | IArray of Rpc.Val.t list
type parse_state = {
mutable cursor: cursor;
let finish_value s v =
match s.stack, v with
| [], _ -> s.cursor <- Done v
- | IObject_needs_key fields :: tl, Rpc.String key ->
+ | IObject_needs_key fields :: tl, `String key ->
s.stack <- IObject_needs_value (fields, key) :: tl;
s.cursor <- Expect_object_elem_colon
| IObject_needs_value (fields, key) :: tl, _ ->
let pop_stack s =
match s.stack with
- | IObject fields :: tl -> s.stack <- tl; finish_value s (Rpc.Struct (List.rev fields))
- | IArray l :: tl -> s.stack <- tl; finish_value s (Rpc.Array (List.rev l))
+ | IObject fields :: tl -> s.stack <- tl; finish_value s (`Dict (List.rev fields))
+ | IArray l :: tl -> s.stack <- tl; finish_value s (`List (List.rev l))
| io :: tl -> raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at pop_stack")
| [] -> raise_internal_error s "empty stack at pop_stack"
let str = tostring_with_leading_zero_check is in
let int = try Int64.of_string str
with Failure _ -> raise_invalid_value s str "int" in
- finish_value s (Rpc.Int int) in
+ finish_value s (`Int int) in
let finish_int_exp is es =
let int = tostring_with_leading_zero_check is in
let exp = clist_to_string (List.rev es) in
returning float is more uniform. *)
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Rpc.Double float) in
+ finish_value s (`Float float) in
let finish_float is fs =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%s" int frac in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Rpc.Double float) in
+ finish_value s (`Float float) in
let finish_float_exp is fs es =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%se%s" int frac exp in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Rpc.Double float) in
+ finish_value s (`Float float) in
match s.cursor with
| Start ->
(match c, rem with
| 'u', 3 -> s.cursor <- In_null 2
| 'l', 2 -> s.cursor <- In_null 1
- | 'l', 1 -> finish_value s Rpc.Nil
+ | 'l', 1 -> finish_value s `None
| _ -> raise_unexpected_char s c "null")
| In_true rem ->
(match c, rem with
| 'r', 3 -> s.cursor <- In_true 2
| 'u', 2 -> s.cursor <- In_true 1
- | 'e', 1 -> finish_value s (Rpc.Bool true)
+ | 'e', 1 -> finish_value s (`Bool true)
| _ -> raise_unexpected_char s c "true")
| In_false rem ->
| 'a', 4 -> s.cursor <- In_false 3
| 'l', 3 -> s.cursor <- In_false 2
| 's', 2 -> s.cursor <- In_false 1
- | 'e', 1 -> finish_value s (Rpc.Bool false)
+ | 'e', 1 -> finish_value s (`Bool false)
| _ -> raise_unexpected_char s c "false")
| In_int is ->
| In_string cs ->
(match c with
| '\\' -> s.cursor <- In_string_control cs
- | '"' -> finish_value s (Rpc.String (clist_to_string (List.rev cs)))
+ | '"' -> finish_value s (`String (clist_to_string (List.rev cs)))
| _ when is_valid_unescaped_char c -> s.cursor <- In_string (c :: cs)
| _ -> raise_unexpected_char s c "string")
| Expect_object_elem_start ->
(match c with
| '"' -> s.stack <- (IObject_needs_key []) :: s.stack; s.cursor <- In_string []
- | '}' -> finish_value s (Rpc.Struct [])
+ | '}' -> finish_value s (`Dict [])
| _ when is_space c -> update_line_num s c
| _ -> raise_unexpected_char s c "object_start")
| Done _ -> raise_internal_error s "parse called when parse_state is 'Done'"
type parse_result =
- | Json_value of Rpc.t * (* number of consumed bytes *) int
+ | Json_value of Rpc.Val.t * (* number of consumed bytes *) int
| Json_parse_incomplete of parse_state
let parse_substring state str ofs len =
- type error =
- | Unexpected_char of int * char * (* json type *) string
- | Invalid_value of int * (* value *) string * (* json type *) string
- | Invalid_leading_zero of int * string
- | Unterminated_value of int * string
- | Internal_error of int * string
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
-exception Parse_error of error
-
-val to_string : Rpc.t -> string
-val of_string : string -> Rpc.t
+val to_string : Rpc.Val.t -> string
+val of_string : string -> Rpc.Val.t
let new_id = Printf.sprintf "__x%i__" !count in
<:expr< $lid:new_id$ >>, <:patt< $lid:new_id$ >>
-(* conversion ML type -> Rpc.Value.t *)
+(* conversion ML type -> Rpc.Val.t *)
module Rpc_of_ML = struct
let rec value_of_ctyp _loc id = function
- | <:ctyp< unit >> -> <:expr< Rpc.String "nil" >>
- | <:ctyp< int >> -> <:expr< Rpc.Int $id$ >>
- | <:ctyp< int32 >> -> <:expr< Rpc.String (Int32.to_string $id$) >>
- | <:ctyp< int64 >> -> <:expr< Rpc.String (Int64.to_string $id$) >>
- | <:ctyp< float >> -> <:expr< Rpc.Double $id$ >>
- | <:ctyp< char >> -> <:expr< Rpc.String (sprintf "%c" $id$) >>
- | <:ctyp< string >> -> <:expr< Rpc.String $id$ >>
- | <:ctyp< bool >> -> <:expr< Rpc.Bool $id$ >>
+ | <:ctyp< unit >> -> <:expr< `None >>
+ | <:ctyp< int >> -> <:expr< `Int (Int64.of_int $id$) >>
+ | <:ctyp< int32 >> -> <:expr< `Int (Int64.of_int32 $id$) >>
+ | <:ctyp< int64 >> -> <:expr< `Int $id$ >>
+ | <:ctyp< float >> -> <:expr< `Float $id$ >>
+ | <:ctyp< char >> -> <:expr< `String (Printf.sprintf "%c" $id$) >>
+ | <:ctyp< string >> -> <:expr< `String $id$ >>
+ | <:ctyp< bool >> -> <:expr< `Bool $id$ >>
| <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
let decomp = decompose_variants _loc t in
let new_id, new_pid = new_id _loc in
match t with
| None ->
- <:match_case< $uid:n$ -> Rpc.Array [ Rpc.String $str:n$ ] >>
+ <:match_case< $uid:n$ -> `List [ `String $str:n$ ] >>
| Some t ->
- <:match_case< $uid:n$ $new_pid$ -> Rpc.Array [ Rpc.String $str:n$; $value_of_ctyp _loc new_id t$ ] >>
+ <:match_case< $uid:n$ $new_pid$ -> `List [ `String $str:n$; $value_of_ctyp _loc new_id t$ ] >>
) decomp in
let pattern = mcOr_of_list patterns in
<:expr< match $id$ with [ $pattern$ ] >>
| <:ctyp< option $t$ >> ->
let new_id, new_pid = new_id _loc in
<:expr< match $id$ with [
- Some $new_pid$ -> Rpc.Array [ $value_of_ctyp _loc new_id t$ ]
- | None -> Rpc.Array []
+ Some $new_pid$ -> `List [ $value_of_ctyp _loc new_id t$ ]
+ | None -> `List []
] >>
| <:ctyp< $tup:tp$ >> ->
let new_ids_patt = List.map (fun (_,_,new_pid) -> new_pid) new_ids in
<:expr<
let $patt_tuple_of_expr _loc new_ids_patt$ = $id$ in
- Rpc.Array $list_of_expr _loc exprs$
+ `List $list_of_expr _loc exprs$
>>
| <:ctyp< list $t$ >> ->
let new_id, new_pid = new_id _loc in
- <:expr< Rpc.Array (List.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$) >>
+ <:expr< `List (List.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$) >>
| <:ctyp< array $t$ >> ->
let new_id, new_pid = new_id _loc in
<:expr<
- Rpc.Array (Array.to_list (Array.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$))
+ `List (Array.to_list (Array.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$))
>>
| <:ctyp< { $t$ } >> ->
let fields = list_of_fields _loc t in
let bindings = List.map (fun (f,_) -> <:binding< $lid:f$ = $id$ . $lid:f$ >>) fields in
- let final_expr = <:expr< Rpc.Struct $list_of_expr _loc (List.map get_name_value fields)$ >> in
+ let final_expr = <:expr< `Dict $list_of_expr _loc (List.map get_name_value fields)$ >> in
biList_to_expr _loc bindings final_expr
| <:ctyp< $lid:t$ >> -> <:expr< $lid:"rpc_of_"^t$ $id$ >>
~fun_name:("rpc_of_"^id)
~final_ident:id
~function_body:(rpc_of _loc id ctyp)
- ~return_type:<:ctyp< Rpc.t >>
+ ~return_type:<:ctyp< Rpc.Val.t >>
[]
end
-(* conversion Rpc.Value.t -> ML type *)
+(* conversion Rpc.Val.t -> ML type *)
module ML_of_rpc = struct
let arg = let _loc = Loc.ghost in <:expr< $lid:"__x__"$ >>
let parse_error expected got =
let _loc = Loc.ghost in
- <:expr< raise (Parse_error( $str:expected^" expected"$, $got$)) >>
+ <:expr< do {
+ Printf.eprintf "Parse error: got '%s' while '%s' was expected.\n" (Rpc.Val.to_string $got$) $str:expected$;
+ raise (Parse_error($str:expected$, $got$)) }
+ >>
let rec value_of_ctyp _loc id = function
| <:ctyp< unit >> ->
- <:expr< match $id$ with [ Rpc.String "nil" -> unit | $parg$ -> $parse_error "String(nil)" arg$ ] >>
+ <:expr< match $id$ with [ `None -> () | $parg$ -> $parse_error "None" arg$ ] >>
| <:ctyp< int >> ->
- <:expr< match $id$ with [ Rpc.Int x -> x | $parg$ -> $parse_error "Int(int)" arg$ ] >>
+ <:expr< match $id$ with [ `Int x -> Int64.to_int x | $parg$ -> $parse_error "Int(int)" arg$ ] >>
| <:ctyp< int32 >> ->
- <:expr< match $id$ with [ Rpc.String x -> Int32.of_string x | $parg$ -> $parse_error "String(int32)" arg$ ] >>
+ <:expr< match $id$ with [ `Int x -> Int64.to_int32 x | $parg$ -> $parse_error "Int(int32)" arg$ ] >>
| <:ctyp< int64 >> ->
- <:expr< match $id$ with [ Rpc.String x -> Int64.of_string x | $parg$ -> $parse_error "String(int64)" arg$ ] >>
+ <:expr< match $id$ with [ `Int x -> x | $parg$ -> $parse_error "Int(int64)" arg$ ] >>
| <:ctyp< float >> ->
- <:expr< match $id$ with [ Rpc.Double x -> x | $parg$ -> $parse_error "Double(flaot)" arg$ ] >>
+ <:expr< match $id$ with [ `Float x -> x | $parg$ -> $parse_error "Float" arg$ ] >>
| <:ctyp< char >> ->
- <:expr< match $id$ with [ Rpc.String x -> x.[0] | $parg$ -> $parse_error "Char(string)" arg$ ] >>
+ <:expr< match $id$ with [ `String x -> x.[0] | $parg$ -> $parse_error "String(char)" arg$ ] >>
| <:ctyp< string >> ->
- <:expr< match $id$ with [ Rpc.String x -> x | $parg$ -> $parse_error "String(string)" arg$ ] >>
+ <:expr< match $id$ with [ `String x -> x | $parg$ -> $parse_error "String(string)" arg$ ] >>
| <:ctyp< bool >> ->
- <:expr< match $id$ with [ Rpc.Bool x -> x | $parg$ -> $parse_error "Bool(bool)" arg$ ] >>
+ <:expr< match $id$ with [ `Bool x -> x | $parg$ -> $parse_error "Bool" arg$ ] >>
| <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
let decomp = decompose_variants _loc t in
let new_id, new_pid = new_id _loc in
match t with
| None ->
- <:match_case< Rpc.Array [ Rpc.String $str:n$ ] -> $uid:n$ >>
+ <:match_case< `List [ `String $str:n$ ] -> $uid:n$ >>
| Some t ->
- <:match_case< Rpc.Array [ Rpc.String $str:n$; $new_pid$ ] -> $uid:n$ $value_of_ctyp _loc new_id t$ >>
+ <:match_case< `List [ `String $str:n$; $new_pid$ ] -> $uid:n$ $value_of_ctyp _loc new_id t$ >>
) decomp
- @ [ <:match_case< $parg$ -> $parse_error "Array[string;_]" arg$ >> ] in
+ @ [ <:match_case< $parg$ -> $parse_error "List[String;_]" arg$ >> ] in
let pattern = mcOr_of_list patterns in
<:expr< match $id$ with [ $pattern$ ] >>
| <:ctyp< option $t$ >> ->
let new_id, new_pid = new_id _loc in
<:expr< match $id$ with [
- Rpc.Array [] -> None
- | Rpc.Array [$new_pid$] -> Some $value_of_ctyp _loc new_id t$
- | $parg$ -> $parse_error "Array[_]" arg$
+ `List [] -> None
+ | `List [$new_pid$] -> Some $value_of_ctyp _loc new_id t$
+ | $parg$ -> $parse_error "List[_]" arg$
] >>
| <:ctyp< $tup:tp$ >> ->
let new_ids_patt = List.map (fun (_,_,new_pid) -> new_pid) new_ids in
let new_id, new_pid = new_id _loc in
<:expr< match $id$ with [
- Rpc.Array $new_pid$ ->
+ `List $new_pid$ ->
match $new_id$ with [
$patt_list_of_expr _loc new_ids_patt$ -> $tuple_of_expr _loc exprs$
- | $parg$ -> $parse_error (Printf.sprintf "list of size %i" (List.length tys)) <:expr< Rpc.Array $arg$ >>$ ]
- | $parg$ -> $parse_error "Array[_]" arg$
+ | $parg$ -> $parse_error (Printf.sprintf "list of size %i" (List.length tys)) <:expr< `List $arg$ >>$ ]
+ | $parg$ -> $parse_error "List[_]" arg$
] >>
| <:ctyp< list $t$ >> ->
let new_id, new_pid = new_id _loc in
<:expr< match $id$ with [
- Rpc.Array $new_pid$ ->
+ `List $new_pid$ ->
let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in
List.map __fn__ $new_id$
- | $parg$ -> $parse_error "Array[_]" arg$
+ | $parg$ -> $parse_error "List[_]" arg$
] >>
| <:ctyp< array $t$ >> ->
let new_id, new_pid = new_id _loc in
<:expr< match $id$ with [
- Rpc.Array $new_pid$ ->
+ `List $new_pid$ ->
let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in
Array.of_list (List.map __fn__ $new_id$)
- | $parg$ -> $parse_error "Array[_]" arg$
+ | $parg$ -> $parse_error "List[_]" arg$
] >>
| <:ctyp< { $t$ } >> ->
let record_bindings = List.map (fun (n,_) -> (n,<:expr< $lid:n$ >>)) fields in
let final_expr = record_of_fields _loc record_bindings in
<:expr< match $id$ with [
- Rpc.Struct $new_pid$ -> $biList_to_expr _loc bindings final_expr$
- | $parg$ -> $parse_error "Struct(_)" arg$
+ `Dict $new_pid$ -> $biList_to_expr _loc bindings final_expr$
+ | $parg$ -> $parse_error "Dict(_)" arg$
] >>
| <:ctyp< $lid:t$ >> -> <:expr< $lid:t^"_of_rpc"$ $id$ >>
(fun ctyp ->
let _loc = loc_of_ctyp ctyp in
<:str_item<
- exception Parse_error of (string * Rpc.t);
+ exception Parse_error of (string * Rpc.Val.t);
value rec $process_type_declaration _loc Rpc_of_ML.process ctyp$;
value rec $process_type_declaration _loc ML_of_rpc.process ctyp$
>>)
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
-(* From http://www.xmlrpc.com/spec *)
-type t =
- | Int of int
- | Bool of bool
- | String of string
- | Double of float
- | Struct of (string * t) list
- | Array of t list
+
+module Sig = struct
+ type t =
+ [ `Int | `Bool | `Float | `String
+ | `Product of t list
+ | `Named_product of (string * t) list
+ | `Named_sum of (string * t) list
+ | `Option of t ]
+end
+
+module Val = struct
+ type t =
+ [ `Int of int64
+ | `Bool of bool
+ | `Float of float
+ | `String of string
+ | `List of t list
+ | `Dict of (string * t) list
+ | `None ]
+
+ let rec to_string (x:t) = match x with
+ | `Int i -> Printf.sprintf "Int(%Lu)" i
+ | `Bool b -> Printf.sprintf "Bool(%b)" b
+ | `Float f -> Printf.sprintf "Float(%f)" f
+ | `String s -> Printf.sprintf "String(%s)" s
+ | `List l -> "List [ " ^ String.concat ", " (List.map to_string l) ^ " ]"
+ | `Dict d -> "Dict {" ^ String.concat ", " (List.map (fun (s,t) -> Printf.sprintf "%s: %s" s (to_string t)) d) ^ " }"
+ | `None -> "None"
+end
+
+(* The first argument is the list of record field names we already went trough *)
+type callback = string list -> Val.t -> unit
+
+type call = {
+ name: string;
+ params: Val.t list
+}
+
+type response =
+ | Success of Val.t
+ | Fault of int * string
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
+
open Printf
let debug = ref false
kprintf (fun s -> if !debug then begin print_string s; print_newline (); flush stdout end) fmt
(* marshalling/unmarshalling code *)
-let rec buffer_add_value buf = function
- | Rpc.Int i ->
- Buffer.add_string buf "<value><int>";
- Buffer.add_string buf (string_of_int i);
- Buffer.add_string buf "</int></value>"
-
- | Rpc.Bool b ->
- Buffer.add_string buf "<value><bool>";
- Buffer.add_string buf (string_of_bool b);
- Buffer.add_string buf "</bool></value>"
-
- | Rpc.String s ->
- Buffer.add_string buf "<value><string>";
- Buffer.add_string buf s;
- Buffer.add_string buf "</string></value>"
-
- | Rpc.Double d ->
- Buffer.add_string buf "<value><double>";
- Buffer.add_string buf (string_of_float d);
- Buffer.add_string buf "</double></value>"
-
- | Rpc.Array a ->
- Buffer.add_string buf "<value><array><data>";
- List.iter (buffer_add_value buf) a;
- Buffer.add_string buf "</data></array></value>"
-
- | Rpc.Struct f ->
- let buffer_add_member (name, value) =
- Buffer.add_string buf "<member><name>";
- Buffer.add_string buf name;
- Buffer.add_string buf "</name>";
- buffer_add_value buf value;
- Buffer.add_string buf "</member>"
+
+(* The XML-RPC is not very clear about what characters can be in a string value ... *)
+let check s =
+ let aux c =
+ let code = int_of_char c in
+ if code <= 31 then
+ failwith (sprintf "%s is not a valid string (it contains char '\\%i')" s code)
+ in
+ for i = 0 to String.length s - 1 do aux s.[i] done;
+ s
+
+let rec add_value f = function
+ | `Int i ->
+ f "<value><i4>";
+ f (Int64.to_string i);
+ f "</i4></value>"
+
+ | `Bool b ->
+ f "<value><bool>";
+ f (string_of_bool b);
+ f "</bool></value>"
+
+ | `Float d ->
+ f "<value><double>";
+ f (string_of_float d);
+ f "</double></value>"
+
+ | `String s ->
+ f "<value><string>";
+ f (check s);
+ f "</string></value>"
+
+ | `List a ->
+ f "<value><array><data>";
+ List.iter (add_value f) a;
+ f "</data></array></value>"
+
+ | `Dict s ->
+ let add_member (name, value) =
+ f "<member><name>";
+ f name;
+ f "</name>";
+ add_value f value;
+ f "</member>"
in
- Buffer.add_string buf "<value><struct>";
- List.iter buffer_add_member f;
- Buffer.add_string buf "</struct></value>"
+ f "<value><struct>";
+ List.iter add_member s;
+ f "</struct></value>"
+
+ | `None ->
+ f "<value><string>nil</string></value>"
let to_string x =
let buf = Buffer.create 128 in
- buffer_add_value buf x;
+ add_value (Buffer.add_string buf) x;
+ Buffer.contents buf
+
+exception Parse_error of string * Xmlm.signal * Xmlm.input
+
+let debug_signal = function
+ | `El_start ((_,tag),_) -> Printf.sprintf "<%s>" tag
+ | `El_end -> "</...>"
+ | `Data d -> Printf.sprintf "%s" d
+ | `Dtd _ -> "<?dtd?>"
+
+let debug_input input =
+ let buf = Buffer.create 1024 in
+ let rec aux tags =
+ if not (Xmlm.eoi input) then begin
+ match Xmlm.input input with
+ | `El_start ((_,tag),_) ->
+ Buffer.add_string buf "<";
+ Buffer.add_string buf tag;
+ Buffer.add_string buf ">";
+ aux (tag :: tags)
+ | `El_end ->
+ begin match tags with
+ | [] ->
+ Buffer.add_string buf "</>";
+ aux tags
+ | h :: t ->
+ Buffer.add_string buf "</";
+ Buffer.add_string buf h;
+ Buffer.add_string buf ">";
+ aux t
+ end
+ | `Data d ->
+ Buffer.add_string buf d;
+ aux tags
+ | `Dtd _ ->
+ aux tags end
+ in
+ aux [];
Buffer.contents buf
-exception Parse_error of string * string
-
-let get_child xml =
- match Xml.children xml with
- | [x] -> x
- | _ -> raise (Parse_error ("get_child", Xml.to_string xml))
-
-let get_content xml =
- debug "Value.get_content(%s)" (Xml.to_string xml);
- Xml.pcdata (get_child xml)
-
-let rec of_xml xml =
- match Xml.tag xml with
- | "value" -> value_of_xml (get_child xml)
- | x -> raise (Parse_error (x, Xml.to_string xml))
-
-and value_of_xml xml =
- match Xml.tag xml with
- | "int" -> Rpc.Int (int_of_string (get_content xml))
- | "bool" -> Rpc.Bool (bool_of_string (get_content xml))
- | "string" -> Rpc.String (get_content xml)
- | "double" -> Rpc.Double (float_of_string (get_content xml))
- | "struct" -> Rpc.Struct (List.map member_of_xml (Xml.children xml))
- | "array" -> data_of_xml (get_child xml)
- | x -> raise (Parse_error (x, Xml.to_string xml))
-
-and data_of_xml xml =
- match Xml.tag xml with
- | "data" -> Rpc.Array (List.map of_xml (Xml.children xml))
- | x -> raise (Parse_error (x, Xml.to_string xml))
-
-and member_of_xml xml =
- match Xml.tag xml with
- | "member" ->
- begin match Xml.children xml with
- | [name; value] -> name_of_xml name, of_xml value
- | _ -> raise (Parse_error ("member_of_xml",Xml.to_string xml))
- end
- | x -> raise (Parse_error (x, Xml.to_string xml))
-
-and name_of_xml xml =
- match Xml.tag xml with
- | "name" ->
- let data = get_child xml in
- debug "Value.name_of_xml.data(%s)" (Xml.to_string data);
- Xml.pcdata data
- | x -> raise (Parse_error (x, Xml.to_string xml))
-
-let of_string str = of_xml (Xml.parse_string str)
+let parse_error n s i =
+ Printf.eprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" (debug_signal s) n (debug_input i);
+ raise (Parse_error (n,s,i))
+
+module Parser = struct
+
+ (* Specific helpers *)
+ let get_data input =
+ match Xmlm.input input with
+ | `Data d -> d
+ | e -> parse_error "..." e input
+
+ let open_tag input =
+ match Xmlm.input input with
+ | `El_start ((_,tag),_) -> tag
+ | e -> parse_error "<...>" e input
+
+ let close_tag input =
+ match Xmlm.input input with
+ | `El_end -> ()
+ | e -> parse_error "</...>" e input
+
+ let map_tags f input =
+ let tag = open_tag input in
+ let r = f input tag in
+ close_tag input;
+ r
+
+ let map_tag tag f input =
+ let t = open_tag input in
+ if t = tag then begin
+ let r = f input in
+ close_tag input;
+ r
+ end else
+ parse_error (Printf.sprintf "<%s>" tag) (`El_start (("",t),[])) input
+
+ let name input = map_tag "name" get_data input
+ let data f input = map_tag "data" f input
+ let value f input = map_tag "value" f input
+ let members f input =
+ let g input =
+ let name = name input in
+ let value = f name input in
+ (name, value) in
+ let r = ref [] in
+ while Xmlm.peek input <> `El_end do
+ r := map_tag "member" g input :: !r
+ done;
+ List.rev !r
+
+
+ (* Basic constructors *)
+ let make_int ?callback accu data : Rpc.Val.t =
+ let r = `Int (Int64.of_string data) in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ let make_bool ?callback accu data : Rpc.Val.t =
+ let r = `Bool (bool_of_string data) in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ let make_double ?callback accu data : Rpc.Val.t =
+ let r = `Float (float_of_string data) in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ let make_string ?callback accu data : Rpc.Val.t =
+ let r = match data with
+ | "nil" -> `None
+ | s -> `String s in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ let make_array ?callback accu data : Rpc.Val.t =
+ let r = `List data in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ let make_struct ?callback accu data : Rpc.Val.t =
+ let r = `Dict data in
+ match callback with
+ | Some f -> f (List.rev accu) r; r
+ | None -> r
+
+ (* General parser functions *)
+ let rec of_xml ?callback accu input =
+ value (map_tags (basic_types ?callback accu)) input
+
+ and basic_types ?callback accu input = function
+ | "int" | "i4" -> make_int ?callback accu (get_data input)
+ | "bool" -> make_bool ?callback accu (get_data input)
+ | "double" -> make_double ?callback accu (get_data input)
+ | "string" -> make_string ?callback accu (get_data input)
+ | "array" -> make_array ?callback accu (data (of_xmls ?callback accu) input)
+ | "struct" -> make_struct ?callback accu (members (fun name -> of_xml ?callback (name::accu)) input)
+ | e -> make_string ?callback accu e
+
+ and of_xmls ?callback accu input =
+ let r = ref [] in
+ while Xmlm.peek input <> `El_end do
+ r := of_xml ?callback accu input :: !r
+ done;
+ List.rev !r
+end
+
+let of_string ?callback str : Rpc.Val.t =
+ let input = Xmlm.make_input (`String (0, str)) in
+ begin match Xmlm.peek input with
+ | `Dtd _ -> ignore (Xmlm.input input)
+ | _ -> () end;
+ Parser.of_xml ?callback [] input
+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
-exception Parse_error of string * string
-val to_string : Rpc.t -> string
-val of_string : string -> Rpc.t
+val to_string : Rpc.Val.t -> string
+val of_string : ?callback:Rpc.callback -> string -> Rpc.Val.t
projects / xcp / xen-api-libs.git / commitdiff