From: Thomas Gazagnaire Date: Fri, 16 Oct 2009 13:50:46 +0000 (+0100) Subject: [rpc-light] upgrade to use xmlm-1.0.1. X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=02061d29656179f24019ea28cd8f11362a8db226;p=xcp%2Fxen-api-libs.git [rpc-light] upgrade to use xmlm-1.0.1. Lots of small changes, starts to become stable so include it in the build. Signed-off-by: Thomas Gazagnaire --- diff --git a/Makefile b/Makefile index 663c497..66be7d0 100644 --- a/Makefile +++ b/Makefile @@ -18,7 +18,7 @@ all: $(MAKE) -C log $(MAKE) -C sha1 $(MAKE) -C xml-light2 -# $(MAKE) -C rpc-light + $(MAKE) -C rpc-light allxen: $(MAKE) -C mmap @@ -36,7 +36,7 @@ install: $(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 @@ -54,7 +54,7 @@ uninstall: $(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 @@ -113,7 +113,7 @@ clean: 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: diff --git a/rpc-light/META-jsonrpc b/rpc-light/META-jsonrpc new file mode 100644 index 0000000..3b027c2 --- /dev/null +++ b/rpc-light/META-jsonrpc @@ -0,0 +1,4 @@ +version = "0.1" +description = "JSON-RPC marshalling/unmarshalling" +archive(byte) = "jsonrpc.cma" +archive(native) = "jsonrpc.cmxa" diff --git a/rpc-light/META-xmlrpc b/rpc-light/META-xmlrpc index 49088ea..435c5fa 100644 --- a/rpc-light/META-xmlrpc +++ b/rpc-light/META-xmlrpc @@ -1,5 +1,5 @@ version = "0.1" description = "XML-RPC marshalling/unmarshalling" -requires = "xml-light2" +requires = "xmlm" archive(byte) = "xmlrpc.cma" archive(native) = "xmlrpc.cmxa" diff --git a/rpc-light/Makefile b/rpc-light/Makefile index 01904fa..32d7019 100644 --- a/rpc-light/Makefile +++ b/rpc-light/Makefile @@ -1,6 +1,6 @@ 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) diff --git a/rpc-light/examples/Makefile b/rpc-light/examples/Makefile index cd38fd3..285e4f4 100644 --- a/rpc-light/examples/Makefile +++ b/rpc-light/examples/Makefile @@ -1,8 +1,8 @@ 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) @@ -14,7 +14,11 @@ all: $(EXECS) $(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 diff --git a/rpc-light/examples/all_types.ml b/rpc-light/examples/all_types.ml index da9c207..c11cd73 100644 --- a/rpc-light/examples/all_types.ml +++ b/rpc-light/examples/all_types.ml @@ -11,6 +11,7 @@ * 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 = { @@ -21,19 +22,38 @@ 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) + diff --git a/rpc-light/jsonrpc.ml b/rpc-light/jsonrpc.ml index 6234704..aa9c91a 100644 --- a/rpc-light/jsonrpc.ml +++ b/rpc-light/jsonrpc.ml @@ -1,7 +1,5 @@ (* - * Copyright (C) 2009 Citrix Ltd. - * Author Prashanth Mundkur - * Author Vincent Hanquez + * 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 @@ -43,18 +41,18 @@ let escape_string s = 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 "}" @@ -96,13 +94,13 @@ module Parser = struct | 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; @@ -199,7 +197,7 @@ module Parser = struct 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, _ -> @@ -213,8 +211,8 @@ module Parser = struct 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" @@ -233,7 +231,7 @@ module Parser = struct 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 @@ -243,14 +241,14 @@ module Parser = struct 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 @@ -258,7 +256,7 @@ module Parser = struct 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 -> @@ -290,14 +288,14 @@ module Parser = struct (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 -> @@ -305,7 +303,7 @@ module Parser = struct | '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 -> @@ -342,7 +340,7 @@ module Parser = struct | 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") @@ -371,7 +369,7 @@ module Parser = struct | 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") @@ -406,7 +404,7 @@ module Parser = struct | 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 = diff --git a/rpc-light/jsonrpc.mli b/rpc-light/jsonrpc.mli index 3d2b33e..2277aed 100644 --- a/rpc-light/jsonrpc.mli +++ b/rpc-light/jsonrpc.mli @@ -1,11 +1,16 @@ - 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 diff --git a/rpc-light/pa_rpc.ml b/rpc-light/pa_rpc.ml index 4f1c754..6cb8c89 100644 --- a/rpc-light/pa_rpc.ml +++ b/rpc-light/pa_rpc.ml @@ -79,18 +79,18 @@ let new_id _loc = 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 @@ -99,9 +99,9 @@ module Rpc_of_ML = struct 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$ ] >> @@ -109,8 +109,8 @@ module Rpc_of_ML = struct | <: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$ >> -> @@ -120,17 +120,17 @@ module Rpc_of_ML = struct 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$ } >> -> @@ -138,7 +138,7 @@ module Rpc_of_ML = struct 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$ >> @@ -154,12 +154,12 @@ module Rpc_of_ML = struct ~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__"$ >> @@ -167,32 +167,35 @@ module ML_of_rpc = struct 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 @@ -201,20 +204,20 @@ module ML_of_rpc = struct 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$ >> -> @@ -224,29 +227,29 @@ module ML_of_rpc = struct 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$ } >> -> @@ -262,8 +265,8 @@ module ML_of_rpc = struct 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$ >> @@ -296,7 +299,7 @@ let () = (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$ >>) diff --git a/rpc-light/rpc.ml b/rpc-light/rpc.ml index 1a06c62..9db3c49 100644 --- a/rpc-light/rpc.ml +++ b/rpc-light/rpc.ml @@ -11,11 +11,44 @@ * 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 diff --git a/rpc-light/xmlrpc.ml b/rpc-light/xmlrpc.ml index 1945a9a..2a0a58a 100644 --- a/rpc-light/xmlrpc.ml +++ b/rpc-light/xmlrpc.ml @@ -11,6 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) + open Printf let debug = ref false @@ -18,95 +19,217 @@ let debug (fmt: ('a, unit, string, unit) format4) : 'a = 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 ""; - Buffer.add_string buf (string_of_int i); - Buffer.add_string buf "" - - | Rpc.Bool b -> - Buffer.add_string buf ""; - Buffer.add_string buf (string_of_bool b); - Buffer.add_string buf "" - - | Rpc.String s -> - Buffer.add_string buf ""; - Buffer.add_string buf s; - Buffer.add_string buf "" - - | Rpc.Double d -> - Buffer.add_string buf ""; - Buffer.add_string buf (string_of_float d); - Buffer.add_string buf "" - - | Rpc.Array a -> - Buffer.add_string buf ""; - List.iter (buffer_add_value buf) a; - Buffer.add_string buf "" - - | Rpc.Struct f -> - let buffer_add_member (name, value) = - Buffer.add_string buf ""; - Buffer.add_string buf name; - Buffer.add_string buf ""; - buffer_add_value buf value; - Buffer.add_string buf "" + +(* 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 ""; + f (Int64.to_string i); + f "" + + | `Bool b -> + f ""; + f (string_of_bool b); + f "" + + | `Float d -> + f ""; + f (string_of_float d); + f "" + + | `String s -> + f ""; + f (check s); + f "" + + | `List a -> + f ""; + List.iter (add_value f) a; + f "" + + | `Dict s -> + let add_member (name, value) = + f ""; + f name; + f ""; + add_value f value; + f "" in - Buffer.add_string buf ""; - List.iter buffer_add_member f; - Buffer.add_string buf "" + f ""; + List.iter add_member s; + f "" + + | `None -> + f "nil" 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 _ -> "" + +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 ""; + 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 + diff --git a/rpc-light/xmlrpc.mli b/rpc-light/xmlrpc.mli index 0cc91ea..6def312 100644 --- a/rpc-light/xmlrpc.mli +++ b/rpc-light/xmlrpc.mli @@ -11,7 +11,6 @@ * 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