|
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index] [Xen-API] [PATCH 02 of 17] [rpc-light] Backport the value library and clean-up the Makefile and the library building
# HG changeset patch # User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx> # Date 1262958466 0 # Node ID 383e08728219228b6818b5f5274202e96c89786e # Parent 5158e68dfc6b17a197655390b0301bfd6fa603ea [rpc-light] Backport the value library and clean-up the Makefile and the library building. The value library is part of the ocaml-orm project available here: http://github.com/avsm/ocaml-orm-sqlite This backport improves multiple points of the value library (which will be upstreamed later), like the polymorphic type variables or the type variable with module names (ie. 'type t = 'a M.tt with rpc' will work). Basically, all the types used by xapi are handles + some minor extensions as objects. Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx> diff -r 5158e68dfc6b -r 383e08728219 forking_executioner/Makefile --- a/forking_executioner/Makefile Fri Jan 08 13:47:46 2010 +0000 +++ b/forking_executioner/Makefile Fri Jan 08 13:47:46 2010 +0000 @@ -31,10 +31,10 @@ libs: $(LIBS) test_forker: test_forker.cmx - $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa jsonrpc.cmxa -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@ + $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa rpc.cmx jsonrpc.cmx -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@ fe: fe_debug.cmx child.cmx fe_main.cmx - $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa jsonrpc.cmxa stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@ + $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa rpc.cmx jsonrpc.cmx stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@ %.cmo: %.ml $(OCAMLC) -c -I ../log -I ../uuid -I ../stdext -thread -o $@ $< diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/rpc-light/META Fri Jan 08 13:47:46 2010 +0000 @@ -0,0 +1,34 @@ +version = "0.2" +description = "RPC light: lightweight library to convert plain ML types to and from RPC values" +requires = "rpc-light.xml, rpc-light.json" + +package "syntax" ( + version = "0.1" + description = "rpc-light: library to marshalling/unmarshalling ML types to/from RPC intermediate language" + requires = "type-conv.syntax" + archive(syntax,preprocessor) = "pa_rpc.cma" + archive(syntax,toploop) = "pa_rpc.cma" + ) + +package "core" ( + version = "0.1" + description = "Common RPC definitions" + archive(byte) = "rpc.cmo" + archive(native) = "rpc.cmx" +) + +package "xml" ( + version = "0.1" + description = "XML-RPC marshalling/unmarshalling" + requires = "rpc-light.core,xmlm" + archive(byte) = "xmlrpc.cmo" + archive(native) = "xmlrpc.cmx" + ) + +package "json" ( + version = "0.1" + description = "JSON-RPC marshalling/unmarshalling" + requires = "rpc-light.core" + archive(byte) = "jsonrpc.cmo" + archive(native) = "jsonrpc.cmx" +) diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-jsonrpc --- a/rpc-light/META-jsonrpc Fri Jan 08 13:47:46 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -version = "0.1" -description = "JSON-RPC marshalling/unmarshalling" -archive(byte) = "jsonrpc.cma" -archive(native) = "jsonrpc.cmxa" diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-rpc-light --- a/rpc-light/META-rpc-light Fri Jan 08 13:47:46 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -version = "0.1" -description = "RPC light: lightweight library to convert plain ML types to and from RPC values" - -package "syntax" - ( - version = "0.1" - description = "pa-rpc: library to marshalling/unmarshalling ML types to/from Rpc.t" - requires = "type-conv.syntax" - archive(syntax,preprocessor) = "pa_rpc.cma" - archive(syntax,toploop) = "pa_rpc.cma" - ) \ No newline at end of file diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-xmlrpc --- a/rpc-light/META-xmlrpc Fri Jan 08 13:47:46 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -version = "0.1" -description = "XML-RPC marshalling/unmarshalling" -requires = "xmlm" -archive(byte) = "xmlrpc.cma" -archive(native) = "xmlrpc.cmxa" diff -r 5158e68dfc6b -r 383e08728219 rpc-light/Makefile --- a/rpc-light/Makefile Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/Makefile Fri Jan 08 13:47:46 2010 +0000 @@ -3,79 +3,47 @@ OCAMLFLAGS = -annot -g PACKS = xmlm -ICAMLP4=-I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv) - -DOCDIR = /myrepos/xen-api-libs.hg/doc +ICAMLP4 = -I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv) +DOCDIR = /myrepos/xen-api-libs.hg/doc +TARGETS = \ + rpc.cmi rpc.cmo rpc.o rpc.cmx \ + pa_rpc.cma \ + xmlrpc.cmi xmlrpc.cmo xmlrpc.o xmlrpc.cmx \ + jsonrpc.cmi jsonrpc.cmo jsonrpc.o jsonrpc.cmx .PHONY: all clean -all: pa_rpc.cma xmlrpc.cmi xmlrpc.cma xmlrpc.cmxa jsonrpc.cmi jsonrpc.cmxa jsonrpc.cma +all: $(TARGETS) - -pa_rpc.cma: rpc.cmo pa_rpc.cmo +pa_rpc.cma: rpc.cmo p4_rpc.cmo pa_rpc.cmo $(OCAMLC) -a $(ICAMLP4) -o $@ $^ -pa_rpc.cmo: pa_rpc.ml +pa_rpc.cmo: pa_rpc.ml p4_rpc.cmo $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $< +p4_rpc.cmo: p4_rpc.ml rpc.cmo + $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $< - -rpc.cmx: rpc.ml - $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $< - -rpc.cmo: rpc.ml - $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $< - - - -%.cmxa: rpc.cmx %.cmx - $(OCAMLOPT) -a -o $@ $^ - -%.cma: rpc.cmo %.cmo - $(OCAMLC) -a -o $@ $^ - - - -xmlrpc.cmx: xmlrpc.ml xmlrpc.cmi rpc.ml +%.o %.cmx: %.ml $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $< -xmlrpc.cmo: xmlrpc.ml xmlrpc.cmi rpc.ml +%.cmo: %.ml $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $< -xmlrpc.cmi: xmlrpc.mli rpc.ml +%.cmi: %.mli %.ml $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $< - -jsonrpc.cmx: jsonrpc.ml jsonrpc.cmi rpc.ml - $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $< - -jsonrpc.cmo: jsonrpc.ml jsonrpc.cmi rpc.ml - $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $< - -jsonrpc.cmi: jsonrpc.mli rpc.ml - $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $< - - .PHONY: install -install: path = $(DESTDIR)$(shell ocamlfind printconf destdir) -install: rpc.cmi pa_rpc.cma xmlrpc.cma xmlrpc.cmxa - mkdir -p $(path) - cp META-xmlrpc META - ocamlfind install -destdir $(path) xmlrpc META xmlrpc.cma xmlrpc.cmxa xmlrpc.cmi rpc.cmi xmlrpc.cmx rpc.cmx xmlrpc.a xmlrpc.o - cp META-jsonrpc META - ocamlfind install -destdir $(path) jsonrpc META jsonrpc.cma jsonrpc.cmxa jsonrpc.cmi rpc.cmi jsonrpc.cmx rpc.cmx jsonrpc.a jsonrpc.o - cp META-rpc-light META - ocamlfind install -destdir $(path) rpc-light META pa_rpc.cma pa_rpc.cmi - rm META +install: INSTALL_PATH = $(DESTDIR)$(shell ocamlfind printconf destdir) +install: all + ocamlfind install -destdir $(INSTALL_PATH) rpc-light META $(TARGETS) .PHONY: uninstall uninstall: - ocamlfind remove xmlrpc - ocamlfind remove jsonrpc ocamlfind remove rpc-light .PHONY: doc doc: $(INTF) python ../doc/doc.py $(DOCDIR) "rpc-light" "package" "jsonrpc pa_rpc rpc xmlrpc" "." "xmlm" "" - + clean: rm -f *.cmo *.cmx *.cma *.cmxa *.annot *.o *.cmi *.a diff -r 5158e68dfc6b -r 383e08728219 rpc-light/examples/Makefile --- a/rpc-light/examples/Makefile Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/examples/Makefile Fri Jan 08 13:47:46 2010 +0000 @@ -2,7 +2,7 @@ OCAMLOPT = ocamlfind ocamlopt OCAMLFLAGS = -annot -g -PACKS = xmlrpc,jsonrpc +PACKS = rpc-light EXAMPLES = all_types EXECS=$(foreach example, $(EXAMPLES), $(example).opt) diff -r 5158e68dfc6b -r 383e08728219 rpc-light/examples/all_types.ml --- a/rpc-light/examples/all_types.ml Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/examples/all_types.ml Fri Jan 08 13:47:46 2010 +0000 @@ -14,8 +14,12 @@ type t = Foo of int | Bar of (int * float) with rpc -type x = { - foo: t; +module M = struct + type m = t with rpc +end + +type 'a x = { + foo: M.m; bar: string; gna: float list; f1: (int option * bool list * float list list) option; @@ -24,67 +28,75 @@ f4: int64; f5: int; f6: (unit * char) list; + f7: 'a list; progress: int array; } with rpc let _ = - let x1 = { + let x = { foo= Foo 3; bar= "ha ha"; gna=[1.; 2.; 3.; 4. ]; f2 = [| "hi",["hi"]; "hou",["hou";"hou"]; "foo", ["b";"a";"r"] |]; - f1 = None; + f1 = Some (None, [true], [[1.]; [2.;3.]]); f3 = Int32.max_int; f4 = Int64.max_int; f5 = max_int; f6 = [ (),'a' ; (),'b' ; (),'c'; (),'d' ; (),'e' ]; + f7 = [ Foo 1; Foo 2; Foo 3 ]; progress = [| 0; 1; 2; 3; 4; 5 |]; } in - let rpc = rpc_of_x x1 in - let xml = Xmlrpc.to_string rpc in - let json = Jsonrpc.to_string rpc in + (* Testing basic marshalling/unmarshalling *) + + let rpc = rpc_of_x M.rpc_of_m x in - Printf.printf "xmlrpc: %s\n\n" xml; - Printf.printf "jsonrpc: %s\n\n" json; + let rpc_xml = Xmlrpc.to_string rpc in + let rpc_json = Jsonrpc.to_string rpc in + + Printf.printf "\n==rpc_xml==\n%s\n" rpc_xml; + Printf.printf "\n==json==\n%s\n" rpc_json; let callback fields value = match (fields, value) with - | ["progress"], `Int i -> Printf.printf "Progress: %Ld\n" i + | ["progress"], Rpc.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 + let x_xml = x_of_rpc M.m_of_rpc (Xmlrpc.of_string ~callback rpc_xml) in + let x_json = x_of_rpc M.m_of_rpc (Jsonrpc.of_string rpc_json) in - Printf.printf "\nSanity check 1:\nx1=x2: %b\nx2=x3: %b\nx1=x3: %b\n\n" (x1 = x2) (x2 = x3) (x1 = x3); + Printf.printf "\n==Sanity check 1==\nx=x_xml: %b\nx=x_json: %b\n" (x = x_xml) (x = x_json); + assert (x = x_xml && x = x_json); - let call = { Rpc.name = "foo"; Rpc.params = [ rpc ] } in - let response1 = Rpc.Success rpc in - let response2 = Rpc.Fault (1L, "Foo") in - let response3 = Rpc.Fault rpc in + (* Testing calls and responses *) + + let call = Rpc.call "foo" [ rpc; Rpc.String "Mouhahahaaaaa" ] in + let success = Rpc.success rpc in + let failure = Rpc.failure rpc in - let c1 = Xmlrpc.string_of_call call in - let r1 = Xmlrpc.string_of_response response1 in - let r2 = Xmlrpc.string_of_response response2 in + let c_xml_str = Xmlrpc.string_of_call call in + let s_xml_str = Xmlrpc.string_of_response success in + let f_xml_str = Xmlrpc.string_of_response failure in - let cj1 = Jsonrpc.string_of_call call in - let rj1 = Jsonrpc.string_of_response 0L response1 in - let rj3 = Jsonrpc.string_of_response 0L response3 in + let c_json_str = Jsonrpc.string_of_call call in + let s_json_str = Jsonrpc.string_of_response success in + let f_json_str = Jsonrpc.string_of_response failure in - Printf.printf "call: %s\n%s\n" c1 cj1; - Printf.printf "response1: %s\n%s\n" r1 rj1; - Printf.printf "response2: %s\n" r2; - Printf.printf "response3: %s\n" rj3; + Printf.printf "\n==call==\n %s\n%s\n" c_xml_str c_json_str; + Printf.printf "\n==success==\n %s\n%s\n" s_xml_str s_json_str; + Printf.printf "\n==failure==\n %s\n%s\n" f_xml_str f_json_str; - let c1' = Xmlrpc.call_of_string c1 in - let r1' = Xmlrpc.response_of_string r1 in - let r2' = Xmlrpc.response_of_string r2 in + let c_xml = Xmlrpc.call_of_string c_xml_str in + let s_xml = Xmlrpc.response_of_string s_xml_str in + let f_xml = Xmlrpc.response_of_string f_xml_str in - Printf.printf "\nSanity check 2:\ncall=c1': %b\nresponse1=r1': %b\nresponse2=r2': %b\n" - (call = c1') (response1 = r1') (response2 = r2'); + (* Printf.printf "\n==Sanity check 2==\ncall=c_xml: %b\nsuccess=s_xml: %b\nfailure=f_xml: %b\n" + (call = c_xml) (success = s_xml) (failure = f_xml); + assert (call = c_xml && success = s_xml && failure = f_xml); *) - let _, cj1' = Jsonrpc.call_of_string cj1 in - let _, rj1' = Jsonrpc.response_of_string rj1 in - let _, rj3' = Jsonrpc.response_of_string rj3 in + let c_json = Jsonrpc.call_of_string c_json_str in + let s_json = Jsonrpc.response_of_string s_json_str in + let f_json = Jsonrpc.response_of_string f_json_str in - Printf.printf "\nSanity check 3:\ncall=cj1': %b\nresponse1=rj1': %b\nresponse3=rj3': %b\n" - (call = cj1') (response1 = rj1') (response3 = rj3'); + Printf.printf "\n==Sanity check 3==\ncall=c_json': %b\nsuccess=s_json': %b\nfailure=f_json': %b\n" + (call = c_json) (success = s_json) (failure = f_json); + assert (call = c_json && success = s_json && failure = f_json) diff -r 5158e68dfc6b -r 383e08728219 rpc-light/jsonrpc.ml --- a/rpc-light/jsonrpc.ml Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/jsonrpc.ml Fri Jan 08 13:47:46 2010 +0000 @@ -43,18 +43,18 @@ let rec to_fct t f = match t with - | `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 -> + | 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) + | Null -> f "null" + | Enum a -> f "["; list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a; f "]"; - | `Dict a -> + | Dict a -> f "{"; - list_iter_between (fun (k, v) -> to_fct (`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 "}" @@ -71,26 +71,26 @@ (fun () -> count := Int64.add 1L !count; !count) let string_of_call call = - let json = `Dict [ - "method", `String call.name; - "params", `List call.params; - "id", `Int (new_id ()); + let json = Dict [ + "method", String call.name; + "params", Enum call.params; + "id", Int (new_id ()); ] in to_string json let string_of_response response = let json = if response.Rpc.success then - `Dict [ + Dict [ "result", response.Rpc.contents; - "error", `None; - "id", `Int 0L + "error", Null; + "id", Int 0L ] else - `Dict [ - "result", `None; + Dict [ + "result", Null; "error", response.Rpc.contents; - "id", `Int 0L + "id", Int 0L ] in to_string json @@ -122,13 +122,13 @@ | Expect_object_elem_colon | Expect_comma_or_end | Expect_object_key - | Done of Val.t + | Done of t type int_value = - | IObject of (string * Val.t) list - | IObject_needs_key of (string * Val.t) list - | IObject_needs_value of (string * Val.t) list * string - | IArray of Val.t list + | IObject of (string * t) list + | IObject_needs_key of (string * t) list + | IObject_needs_value of (string * t) list * string + | IArray of t list type parse_state = { mutable cursor: cursor; @@ -224,7 +224,7 @@ let finish_value s v = match s.stack, v with | [], _ -> s.cursor <- Done v - | IObject_needs_key fields :: tl, `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, _ -> @@ -238,8 +238,8 @@ let pop_stack s = match s.stack with - | 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)) + | IObject fields :: tl -> s.stack <- tl; finish_value s (Dict (List.rev fields)) + | IArray l :: tl -> s.stack <- tl; finish_value s (Enum (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" @@ -258,7 +258,7 @@ 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 (`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 @@ -268,14 +268,14 @@ returning float is more uniform. *) let float = try float_of_string str with Failure _ -> raise_invalid_value s str "float" in - finish_value s (`Float 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 (`Float 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 @@ -283,7 +283,7 @@ 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 (`Float float) in + finish_value s (Float float) in match s.cursor with | Start -> @@ -315,14 +315,14 @@ (match c, rem with | 'u', 3 -> s.cursor <- In_null 2 | 'l', 2 -> s.cursor <- In_null 1 - | 'l', 1 -> finish_value s `None + | 'l', 1 -> finish_value s Null | _ -> 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 (`Bool true) + | 'e', 1 -> finish_value s (Bool true) | _ -> raise_unexpected_char s c "true") | In_false rem -> @@ -330,7 +330,7 @@ | '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 (`Bool false) + | 'e', 1 -> finish_value s (Bool false) | _ -> raise_unexpected_char s c "false") | In_int is -> @@ -367,7 +367,7 @@ | In_string cs -> (match c with | '\\' -> s.cursor <- In_string_control cs - | '"' -> finish_value s (`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") @@ -396,7 +396,7 @@ | Expect_object_elem_start -> (match c with | '"' -> s.stack <- (IObject_needs_key []) :: s.stack; s.cursor <- In_string [] - | '}' -> finish_value s (`Dict []) + | '}' -> finish_value s (Dict []) | _ when is_space c -> update_line_num s c | _ -> raise_unexpected_char s c "object_start") @@ -431,7 +431,7 @@ | Done _ -> raise_internal_error s "parse called when parse_state is 'Done'" type parse_result = - | Json_value of Val.t * (* number of consumed bytes *) int + | Json_value of t * (* number of consumed bytes *) int | Json_parse_incomplete of parse_state let parse_substring state str ofs len = @@ -497,24 +497,24 @@ let call_of_string str = match of_string str with - | `Dict d -> - let name = match get "method" d with `String s -> s | _ -> raise (Malformed_method_request str) in - let params = match get "params" d with `List l -> l | _ -> raise (Malformed_method_request str) in - let (_:int64) = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_request str) in - { name = name; params = params } + | Dict d -> + let name = match get "method" d with String s -> s | _ -> raise (Malformed_method_request str) in + let params = match get "params" d with Enum l -> l | _ -> raise (Malformed_method_request str) in + let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_request str) in + call name params | _ -> raise (Malformed_method_request str) let response_of_string str = match of_string str with - | `Dict d -> + | Dict d -> let result = get "result" d in let error = get "error" d in - let (_:int64) = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_response str) in + let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_response str) in begin match result, error with - | `None, `None -> raise (Malformed_method_response str) - | `None, v -> { Rpc.success = false; contents = v } - | v, `None -> { Rpc.success = true; contents = v } - | _ -> raise (Malformed_method_response str) + | Null, Null -> raise (Malformed_method_response str) + | Null, v -> failure v + | v, Null -> success v + | _ -> raise (Malformed_method_response str) end | _ -> raise (Malformed_method_response str) diff -r 5158e68dfc6b -r 383e08728219 rpc-light/jsonrpc.mli --- a/rpc-light/jsonrpc.mli Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/jsonrpc.mli Fri Jan 08 13:47:46 2010 +0000 @@ -12,8 +12,8 @@ * GNU Lesser General Public License for more details. *) -val to_string : Rpc.Val.t -> string -val of_string : string -> Rpc.Val.t +val to_string : Rpc.t -> string +val of_string : string -> Rpc.t val string_of_call: Rpc.call -> string val call_of_string: string -> Rpc.call diff -r 5158e68dfc6b -r 383e08728219 rpc-light/p4_rpc.ml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/rpc-light/p4_rpc.ml Fri Jan 08 13:47:46 2010 +0000 @@ -0,0 +1,369 @@ +(* + * Copyright (c) 2009 Thomas Gazagnaire <thomas@xxxxxxxxxxxxxx> + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Camlp4 +open PreCast +open Ast +open Syntax + +let rpc_of n = "rpc_of_" ^ n +let of_rpc n = n ^ "_of_rpc" + +let rpc_of_polyvar a = "__rpc_of_" ^ a ^ "__" +let of_rpc_polyvar a = "__" ^ a ^ "_of_rpc__" + +let rpc_of_i i = "__rpc_of_" ^ string_of_int i ^ "__" +let of_rpc_i i = "__" ^ string_of_int i ^ "_of_rpc__" + +(* Utils *) + +let list_foldi f step0 l = + fst (List.fold_left (fun (accu, i) x -> f accu x i, i+1) (step0, 0) l) + +let list_of_ctyp_decl tds = + let rec aux accu = function + | Ast.TyAnd (loc, tyl, tyr) -> aux (aux accu tyl) tyr + | Ast.TyDcl (loc, id, args, ty, []) -> (id, args, ty) :: accu + | _ -> failwith "list_of_ctyp_decl: unexpected type" + in aux [] tds + +let rec decompose_fields _loc fields = + match fields with + | <:ctyp< $t1$; $t2$ >> -> + decompose_fields _loc t1 @ decompose_fields _loc t2 + | <:ctyp< $lid:field_name$: mutable $t$ >> | <:ctyp< $lid:field_name$: $t$ >> -> + [ field_name, t ] + | _ -> failwith "unexpected type while processing fields" + +let expr_list_of_list _loc exprs = + match List.rev exprs with + | [] -> <:expr< [] >> + | h::t -> List.fold_left (fun accu x -> <:expr< [ $x$ :: $accu$ ] >>) <:expr< [ $h$ ] >> t + +let patt_list_of_list _loc patts = + match List.rev patts with + | [] -> <:patt< [] >> + | h::t -> List.fold_left (fun accu x -> <:patt< [ $x$ :: $accu$ ] >>) <:patt< [ $h$ ] >> t + +let expr_tuple_of_list _loc = function + | [] -> <:expr< >> + | [x] -> x + | h::t -> ExTup (_loc, List.fold_left (fun accu n -> <:expr< $accu$, $n$ >>) h t) + +let patt_tuple_of_list _loc = function + | [] -> <:patt< >> + | [x] -> x + | h::t -> PaTup (_loc, List.fold_left (fun accu n -> <:patt< $accu$, $n$ >>) h t) + +let name_of_polyvar _loc = function + | <:ctyp< '$lid:a$ >> -> a + | _ -> failwith "name_of_polyvar" + +let rec decompose_args _loc = function + | <:ctyp< $x$ $y$ >> -> decompose_args _loc x @ decompose_args _loc y + | <:ctyp< $x$ >> -> [x] + +let decompose_variants _loc variant = + let rec fn accu = function + | <:ctyp< $t$ | $u$ >> -> fn (fn accu t) u + | <:ctyp< $uid:id$ of $t$ >> -> ((id, `V) , list_of_ctyp t []) :: accu + | <:ctyp< `$uid:id$ of $t$ >> -> ((id, `PV), list_of_ctyp t []) :: accu + | <:ctyp< $uid:id$ >> -> ((id, `V) , []) :: accu + | <:ctyp< `$uid:id$ >> -> ((id, `PV), []) :: accu + | _ -> failwith "decompose_variant" + in + List.split (fn [] variant) + +let recompose_variant _loc (n, t) patts = + match t, patts with + | `V , [] -> <:patt< $uid:n$ >> + | `PV, [] -> <:patt< `$uid:n$ >> + | `V , _ -> <:patt< $uid:n$ $patt_tuple_of_list _loc patts$ >> + | `PV, _ -> <:patt< `$uid:n$ $patt_tuple_of_list _loc patts$ >> + +let count = ref 0 +let new_id _loc = + incr count; + let new_id = Printf.sprintf "__x%i__" !count in + <:expr< $lid:new_id$ >>, <:patt< $lid:new_id$ >> + +let new_id_list _loc l = + List.split (List.map (fun _ -> new_id _loc) l) + +exception Type_not_supported of ctyp +let type_not_supported ty = + let module PP = Camlp4.Printers.OCaml.Make(Syntax) in + let pp = new PP.printer () in + Format.eprintf "Type %a@. not supported.\n%!" pp#ctyp ty; + failwith "type_not_supported" + +let apply _loc fn fn_i create id modules t a = + let args = decompose_args _loc a in + let app expr = list_foldi (fun accu _ i -> <:expr< $accu$ $lid:fn_i i$ >>) expr args in + let expr = match modules with + | None -> <:expr< $app <:expr< $lid:fn t$ >>$ $id$ >> + | Some ms -> <:expr< $app <:expr< $id:ms$ . $lid:fn t$ >>$ $id$ >> in + list_foldi + (fun accu arg i -> + let id, pid = new_id _loc in + <:expr< let $lid:fn_i i$ = fun $pid$ -> $create id arg$ in $accu$ >>) + expr + args + +(* Conversion ML type -> Rpc.value *) +module Rpc_of = struct + + let rec create id ctyp = + let _loc = loc_of_ctyp ctyp in + match ctyp with + | <:ctyp< unit >> -> <:expr< Rpc.Null >> + | <:ctyp< int >> -> <:expr< Rpc.Int (Int64.of_int $id$) >> + | <:ctyp< int32 >> -> <:expr< Rpc.Int (Int64.of_int32 $id$) >> + | <:ctyp< int64 >> -> <:expr< Rpc.Int $id$ >> + | <:ctyp< float >> -> <:expr< Rpc.Float $id$ >> + | <:ctyp< char >> -> <:expr< Rpc.Int (Int64.of_int (Char.code $id$)) >> + | <:ctyp< string >> -> <:expr< Rpc.String $id$ >> + | <:ctyp< bool >> -> <:expr< Rpc.Bool $id$ >> + + | <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> -> + let ids, ctyps = decompose_variants _loc t in + let pattern (n, t) ctyps = + let ids, pids = new_id_list _loc ctyps in + let body = <:expr< Rpc.Enum [ Rpc.String $str:n$ :: $expr_list_of_list _loc (List.map2 create ids ctyps)$ ] >> in + <:match_case< $recompose_variant _loc (n,t) pids$ -> $body$ >> in + let patterns = mcOr_of_list (List.map2 pattern ids ctyps) in + <:expr< match $id$ with [ $patterns$ ] >> + + | <:ctyp< option $t$ >> -> + let new_id, new_pid = new_id _loc in + <:expr< match $id$ with [ Some $new_pid$ -> Rpc.Enum [ $create new_id t$ ] | None -> Rpc.Enum [] ] >> + + | <:ctyp< $tup:tp$ >> -> + let ctyps = list_of_ctyp tp [] in + let ids, pids = new_id_list _loc ctyps in + let exprs = List.map2 create ids ctyps in + <:expr< + let $patt_tuple_of_list _loc pids$ = $id$ in + Rpc.Enum $expr_list_of_list _loc exprs$ + >> + + | <:ctyp< list $t$ >> -> + let new_id, new_pid = new_id _loc in + <:expr< Rpc.Enum (List.map (fun $new_pid$ -> $create new_id t$) $id$) >> + + | <:ctyp< array $t$ >> -> + let new_id, new_pid = new_id _loc in + <:expr< Rpc.Enum (Array.to_list (Array.map (fun $new_pid$ -> $create new_id t$) $id$)) >> + + | <:ctyp< { $t$ } >> -> + let fields = decompose_fields _loc t in + let ids, pids = new_id_list _loc fields in + let bindings = List.map2 (fun pid (f, _) -> <:binding< $pid$ = $id$ . $lid:f$ >>) pids fields in + let one_expr nid (n, ctyp) = <:expr< ($str:n$, $create nid ctyp$) >> in + let expr = <:expr< Rpc.Dict $expr_list_of_list _loc (List.map2 one_expr ids fields)$ >> in + <:expr< let $biAnd_of_list bindings$ in $expr$ >> + + | <:ctyp< < $t$ > >> -> + let fields = decompose_fields _loc t in + let ids, pids = new_id_list _loc fields in + let bindings = List.map2 (fun pid (f, _) -> <:binding< $pid$ = $id$ # $lid:f$ >>) pids fields in + let one_expr nid (n, ctyp) = <:expr< ($str:n$, $create nid ctyp$) >> in + let expr = <:expr< Rpc.Dict $expr_list_of_list _loc (List.map2 one_expr ids fields)$ >> in + <:expr< let $biAnd_of_list bindings$ in $expr$ >> + + | <:ctyp< '$lid:a$ >> -> <:expr< $lid:rpc_of_polyvar a$ $id$ >> + + | <:ctyp< $lid:t$ >> -> <:expr< $lid:rpc_of t$ $id$ >> + | <:ctyp< $id:m$ . $lid:t$ >> -> <:expr< $id:m$ . $lid:rpc_of t$ $id$ >> + + | <:ctyp< $lid:t$ $a$ >> -> apply _loc rpc_of rpc_of_i create id None t a + | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc rpc_of rpc_of_i create id (Some m) t a + + | _ -> type_not_supported ctyp + + let gen_one (name, args, ctyp) = + let _loc = loc_of_ctyp ctyp in + let id, pid = new_id _loc in + <:binding< $lid:rpc_of name$ = + $List.fold_left + (fun accu arg -> <:expr< fun $lid:rpc_of_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>) + (<:expr< fun $pid$ -> $create id ctyp$ >>) + args$ + >> + + let gen tds = + let _loc = loc_of_ctyp tds in + let bindings = List.map gen_one (list_of_ctyp_decl tds) in + biAnd_of_list bindings +end + + +(* Conversion Rpc.value -> ML type *) +module Of_rpc = struct + + let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc< $str:s$ >> | _ -> assert false + + let runtime_error id expected = + let _loc = Loc.ghost in + <:match_case< __x__ -> + failwith (Printf.sprintf "Runtime error while parsing '%s': got '%s' while '%s' was expected\\n" $str_of_id id$ (Rpc.to_string __x__) $str:expected$) + >> + + let runtime_exn_error id doing = + let _loc = Loc.ghost in + <:match_case< __x__ -> + failwith (Printf.sprintf "Runtime error while parsing '%s': got exception '%s' while doing '%s'\\n" $str_of_id id$ (Printexc.to_string __x__) $str:doing$) + >> + + let rec create id ctyp = + let _loc = loc_of_ctyp ctyp in + match ctyp with + | <:ctyp< unit >> -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error id "Null"$ ] >> + + | <:ctyp< int >> -> + <:expr< match $id$ with [ + Rpc.Int x -> Int64.to_int x + | Rpc.String s -> int_of_string s + | $runtime_error id "Int(int)"$ ] >> + + | <:ctyp< int32 >> -> + <:expr< match $id$ with [ + Rpc.Int x -> Int64.to_int32 x + | Rpc.String s -> Int32.of_string s + | $runtime_error id "Int(int32)"$ ] >> + + | <:ctyp< int64 >> -> + <:expr< match $id$ with [ + Rpc.Int x -> x + | Rpc.String s -> Int64.of_string s + | $runtime_error id "Int(int64)"$ ] >> + + | <:ctyp< float >> -> + <:expr< match $id$ with [ + Rpc.Float x -> x + | Rpc.String s -> float_of_string s + | $runtime_error id "Float"$ ] >> + + | <:ctyp< char >> -> + <:expr< match $id$ with [ + Rpc.Int x -> Char.chr (Int64.to_int x) + | Rpc.String s -> Char.chr (int_of_string s) + | $runtime_error id "Int(char)"$ ] >> + + | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x -> x | $runtime_error id "String(string)"$ ] >> + | <:ctyp< bool >> -> <:expr< match $id$ with [ Rpc.Bool x -> x | $runtime_error id "Bool"$ ] >> + + | <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> -> + let ids, ctyps = decompose_variants _loc t in + let pattern (n, t) ctyps = + let ids, pids = new_id_list _loc ctyps in + let patt = <:patt< Rpc.Enum [ Rpc.String $str:n$ :: $patt_list_of_list _loc pids$ ] >> in + let exprs = List.map2 create ids ctyps in + let body = List.fold_right + (fun a b -> <:expr< $b$ $a$ >>) + (List.rev exprs) + (if t = `V then <:expr< $uid:n$ >> else <:expr< `$uid:n$ >>) in + <:match_case< $patt$ -> $body$ >> in + let fail_match = <:match_case< $runtime_error id "Enum[String s;...]"$ >> in + let patterns = mcOr_of_list (List.map2 pattern ids ctyps @ [ fail_match ]) in + <:expr< match $id$ with [ $patterns$ ] >> + + | <:ctyp< option $t$ >> -> + let nid, npid = new_id _loc in + <:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create nid t$ | $runtime_error id "Enum[]/Enum[_]"$ ] >> + + | <:ctyp< $tup:tp$ >> -> + let ctyps = list_of_ctyp tp [] in + let ids, pids = new_id_list _loc ctyps in + let exprs = List.map2 create ids ctyps in + <:expr< match $id$ with + [ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error id "List"$ ] + >> + + | <:ctyp< list $t$ >> -> + let nid, npid = new_id _loc in + let nid2, npid2 = new_id _loc in + <:expr< match $id$ with + [ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create nid2 t$) $nid$ | $runtime_error id "List"$ ] + >> + + | <:ctyp< array $t$ >> -> + let nid, npid = new_id _loc in + let nid2, npid2 = new_id _loc in + <:expr< match $id$ with + [ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create nid2 t$) $nid$) | $runtime_error id "List"$ ] + >> + + | <:ctyp< { $t$ } >> -> + let nid, npid = new_id _loc in + let fields = decompose_fields _loc t in + let ids, pids = new_id_list _loc fields in + let exprs = List.map2 (fun id (n, ctyp) -> <:rec_binding< $lid:n$ = $create id ctyp$ >>) ids fields in + let bindings = + List.map2 (fun pid (n, ctyp) -> + <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >> + ) pids fields in + <:expr< match $id$ with + [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in { $rbSem_of_list exprs$ } | $runtime_error id "Dict"$ ] + >> + + | <:ctyp< < $t$ > >> -> + let nid, npid = new_id _loc in + let fields = decompose_fields _loc t in + let ids, pids = new_id_list _loc fields in + let exprs = List.map2 (fun id (n, ctyp) -> <:class_str_item< method $lid:n$ = $create id ctyp$ >>) ids fields in + let bindings = + List.map2 (fun pid (n, ctyp) -> + <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >> + ) pids fields in + <:expr< match $id$ with + [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in object $crSem_of_list exprs$ end | $runtime_error id "Dict"$ ] + >> + + | <:ctyp< '$lid:a$ >> -> <:expr< $lid:of_rpc_polyvar a$ $id$ >> + + | <:ctyp< $lid:t$ >> -> <:expr< $lid:of_rpc t$ $id$ >> + | <:ctyp< $id:m$ . $lid:t$ >> -> <:expr< $id:m$ . $lid:of_rpc t$ $id$ >> + + | <:ctyp< $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i create id None t a + | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i create id (Some m) t a + + | _ -> type_not_supported ctyp + + let gen_one (name, args, ctyp) = + let _loc = loc_of_ctyp ctyp in + let id, pid = new_id _loc in + <:binding< $lid:of_rpc name$ = + $List.fold_left + (fun accu arg -> <:expr< fun $lid:of_rpc_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>) + (<:expr< fun $pid$ -> $create id ctyp$ >>) + args$ + >> + + let gen tds = + let _loc = loc_of_ctyp tds in + let bindings = List.map gen_one (list_of_ctyp_decl tds) in + biAnd_of_list bindings +end + + +let gen tds = + let _loc = loc_of_ctyp tds in + <:str_item< + value rec $Of_rpc.gen tds$; + value rec $Rpc_of.gen tds$; + >> + diff -r 5158e68dfc6b -r 383e08728219 rpc-light/pa_rpc.ml --- a/rpc-light/pa_rpc.ml Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/pa_rpc.ml Fri Jan 08 13:47:46 2010 +0000 @@ -11,295 +11,14 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(* -pp camlp4orf *) open Camlp4 open PreCast open Ast -open Syntax -(* utils *) +open Pa_type_conv -let biList_to_expr _loc bindings final = - List.fold_right - (fun b a -> <:expr< let $b$ in $a$ >>) - bindings final - -let function_with_label_args _loc ~fun_name ~final_ident ~function_body ~return_type opt_args = - let opt_args = opt_args @ [ <:patt< $lid:final_ident$ >> ] in - <:binding< $lid:fun_name$ = - $List.fold_right (fun b a -> - <:expr<fun $b$ -> $a$ >> - ) opt_args <:expr< ( $function_body$ : $return_type$ ) >> - $ >> - -let rec list_of_fields _loc fields = - match fields with - | <:ctyp< $t1$; $t2$ >> -> - list_of_fields _loc t1 @ list_of_fields _loc t2 - | <:ctyp< $lid:field_name$: mutable $t$ >> | <:ctyp< $lid:field_name$: $t$ >> -> - [ field_name, t ] - | _ -> failwith "unexpected type while processing fields" - -let record_of_fields _loc fields = - let rec_bindings = List.map (fun (n,e) -> Ast.RbEq(_loc, <:ident< $lid:n$ >>, e)) fields in - <:expr< { $rbSem_of_list rec_bindings$ } >> - -let list_of_expr _loc exprs = - match List.rev exprs with - | [] -> <:expr< [ ] >> - | h::t -> List.fold_left (fun accu x -> <:expr< [ $x$ :: $accu$ ] >>) <:expr< [ $h$ ] >> t - -let patt_list_of_expr _loc patts = - match List.rev patts with - | [] -> assert false - | h::t -> List.fold_left (fun accu x -> <:patt< [ $x$ :: $accu$ ] >>) <:patt< [ $h$ ] >> t - -let tuple_of_expr _loc exprs = - match List.rev exprs with - | [] -> assert false - | h::t -> Ast.ExTup ( _loc, List.fold_left (fun accu x -> <:expr< $x$,$accu$ >>) h t) -(* BUG? <:expr< ( $exCom_of_list exprs$ ) doesn't work >> *) - -let patt_tuple_of_expr _loc patts = - Ast.PaTup (_loc, paCom_of_list patts) -(* BUG? <:patt< ( $paCom_of_list patts$ ) doesn't work >> *) - -let decompose_variants _loc variant = - let rec fn accu = function - | <:ctyp< $t$ | $u$ >> -> fn (fn accu t) u - | <:ctyp< $uid:id$ of $t$ >> -> (id, Some t) :: accu - | <:ctyp< $uid:id$ >> -> (id, None) :: accu - | _ -> failwith "decompose_variant" - in fn [] variant - -let count = ref 0 -let new_id _loc = - incr count; - let new_id = Printf.sprintf "__x%i__" !count in - <:expr< $lid:new_id$ >>, <:patt< $lid:new_id$ >> - -(* conversion ML type -> Rpc.Val.t *) -module Rpc_of_ML = struct - - let rec value_of_ctyp _loc id = function - | <: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 patterns = - List.map (fun (n, t) -> - let new_id, new_pid = new_id _loc in - match t with - | None -> - <:match_case< $uid:n$ -> `List [ `String $str:n$ ] >> - | Some 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$ -> `List [ $value_of_ctyp _loc new_id t$ ] - | None -> `List [] - ] >> - - | <:ctyp< $tup:tp$ >> -> - let tys = list_of_ctyp tp [] in - let new_ids = List.map (fun t -> let new_id, new_pid = new_id _loc in (t,new_id, new_pid)) tys in - let exprs = List.map (fun (t,new_id,_) -> value_of_ctyp _loc new_id t) new_ids in - 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 - `List $list_of_expr _loc exprs$ - >> - - | <:ctyp< list $t$ >> -> - let new_id, new_pid = new_id _loc in - <: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< - `List (Array.to_list (Array.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$)) - >> - - | <:ctyp< { $t$ } >> -> - let get_name_value (n,ctyp) = <:expr< ($str:n$, $value_of_ctyp _loc <:expr< $lid:n$ >> ctyp$) >> in - - 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< `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$ >> - - | _ -> failwith "Rpc_of_ML.value_of_ctyp: type not supported" - - let rpc_of _loc id ctyp = - let id = <:expr< $lid:id$ >> in - value_of_ctyp _loc id ctyp - - let process _loc id ctyp = - function_with_label_args _loc - ~fun_name:("rpc_of_"^id) - ~final_ident:id - ~function_body:(rpc_of _loc id ctyp) - ~return_type:<:ctyp< Rpc.Val.t >> - [] - -end - -(* conversion Rpc.Val.t -> ML type *) -module ML_of_rpc = struct - - let arg = let _loc = Loc.ghost in <:expr< $lid:"__x__"$ >> - let parg = let _loc = Loc.ghost in <:patt< $lid:"__x__"$ >> - - let parse_error expected got = - let _loc = Loc.ghost in - <: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 [ `None -> () | $parg$ -> $parse_error "None" arg$ ] >> - - | <:ctyp< int >> -> - <:expr< match $id$ with [ `Int x -> Int64.to_int x | $parg$ -> $parse_error "Int(int)" arg$ ] >> - - | <:ctyp< int32 >> -> - <:expr< match $id$ with [ `Int x -> Int64.to_int32 x | $parg$ -> $parse_error "Int(int32)" arg$ ] >> - - | <:ctyp< int64 >> -> - <:expr< match $id$ with [ `Int x -> x | $parg$ -> $parse_error "Int(int64)" arg$ ] >> - - | <:ctyp< float >> -> - <:expr< match $id$ with [ `Float x -> x | $parg$ -> $parse_error "Float" arg$ ] >> - - | <:ctyp< char >> -> - <:expr< match $id$ with [ `String x -> x.[0] | $parg$ -> $parse_error "String(char)" arg$ ] >> - - | <:ctyp< string >> -> - <:expr< match $id$ with [ `String x -> x | $parg$ -> $parse_error "String(string)" arg$ ] >> - - | <:ctyp< bool >> -> - <: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 patterns = - List.map (fun (n,t) -> - let new_id, new_pid = new_id _loc in - match t with - | None -> - <:match_case< `List [ `String $str:n$ ] -> $uid:n$ >> - | Some t -> - <:match_case< `List [ `String $str:n$; $new_pid$ ] -> $uid:n$ $value_of_ctyp _loc new_id t$ >> - ) decomp - @ [ <: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 [ - `List [] -> None - | `List [$new_pid$] -> Some $value_of_ctyp _loc new_id t$ - | $parg$ -> $parse_error "List[_]" arg$ - ] >> - - | <:ctyp< $tup:tp$ >> -> - let tys = list_of_ctyp tp [] in - let new_ids = List.map (fun t -> let new_id, new_pid = new_id _loc in (t,new_id,new_pid)) tys in - let exprs = List.map (fun (t,new_id,mew_pid) -> value_of_ctyp _loc new_id t) new_ids in - 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 [ - `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< `List $arg$ >>$ ] - | $parg$ -> $parse_error "List[_]" arg$ - ] >> - - | <:ctyp< list $t$ >> -> - let new_id, new_pid = new_id _loc in - <:expr< match $id$ with [ - `List $new_pid$ -> - let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in - List.map __fn__ $new_id$ - | $parg$ -> $parse_error "List[_]" arg$ - ] >> - - | <:ctyp< array $t$ >> -> - let new_id, new_pid = new_id _loc in - <:expr< match $id$ with [ - `List $new_pid$ -> - let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in - Array.of_list (List.map __fn__ $new_id$) - | $parg$ -> $parse_error "List[_]" arg$ - ] >> - - | <:ctyp< { $t$ } >> -> - let new_id, new_pid = new_id _loc in - let fields = list_of_fields _loc t in - let bindings = - List.map (fun (n,ctyp) -> - <:binding< $lid:n$ = - let __f__ $parg$ = $value_of_ctyp _loc arg ctyp$ in - __f__ (try List.assoc $str:n$ $new_id$ with [ Not_found -> $parse_error ("key "^n) id$ ]) - >>) - fields in - 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 [ - `Dict $new_pid$ -> $biList_to_expr _loc bindings final_expr$ - | $parg$ -> $parse_error "Dict(_)" arg$ - ] >> - - | <:ctyp< $lid:t$ >> -> <:expr< $lid:t^"_of_rpc"$ $id$ >> - - | _ -> failwith "ML_of_rpc.scalar_of_ctyp: unsuported type" - - let of_rpc _loc id ctyp = - let id = <:expr< $lid:id$ >> in - value_of_ctyp _loc id ctyp - - let process _loc id ctyp = - function_with_label_args _loc - ~fun_name:(id^"_of_rpc") - ~final_ident:id - ~function_body:(of_rpc _loc id ctyp) - ~return_type:<:ctyp< $lid:id$ >> - [] - -end - -let process_type_declaration _loc process ctyp = - let rec fn ty accu = match ty with - | Ast.TyAnd (_loc, tyl, tyr) -> fn tyl (fn tyr accu) - | Ast.TyDcl (_loc, id, _, ty, []) -> process _loc id ty :: accu - | _ -> accu in - biAnd_of_list (fn ctyp []) - -let () = - Pa_type_conv.add_generator "rpc" - (fun ctyp -> - let _loc = loc_of_ctyp ctyp in - <:str_item< - 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$ - >>) +let _ = + add_generator "rpc" (fun tds -> + let _loc = loc_of_ctyp tds in + <:str_item< $P4_rpc.gen tds$ >>) diff -r 5158e68dfc6b -r 383e08728219 rpc-light/rpc.ml --- a/rpc-light/rpc.ml Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/rpc.ml Fri Jan 08 13:47:46 2010 +0000 @@ -12,44 +12,52 @@ * GNU Lesser General Public License for more details. *) -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 +type t = + | Int of int64 + | Bool of bool + | Float of float + | String of string + | Enum of t list + | Dict of (string * t) list + | Null -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 ] +open Printf +let map_strings sep fn l = String.concat sep (List.map fn l) +let rec to_string t = match t with + | Int i -> sprintf "I(%Li)" i + | Bool b -> sprintf "B(%b)" b + | Float f -> sprintf "F(%g)" f + | String s -> sprintf "S(%s)" s + | Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts) + | Dict ts -> sprintf "{%s}" (map_strings ";" (fun (s,t) -> sprintf "%s:%s" s (to_string t)) ts) + | Null -> "N" - 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 +let rpc_of_t x = x +let rpc_of_int64 i = Int i +let rpc_of_bool b = Bool b +let rpc_of_float f = Float f +let rpc_of_string s = String s + +let t_of_rpc x = x +let int64_of_rpc = function Int i -> i | _ -> failwith "int64_of_rpc" +let bool_of_rpc = function Bool b -> b | _ -> failwith "bool_of_rpc" +let float_of_rpc = function Float f -> f | _ -> failwith "float_of_rpc" +let string_of_rpc = function String s -> s | _ -> failwith "string_of_rpc" + +type callback = string list -> t -> unit type call = { name: string; - params: Val.t list + params: t list; } + +let call name params = { name = name; params = params } type response = { success: bool; - contents: Val.t + contents: t; } + +let success v = { success = true; contents = v } +let failure v = { success = false; contents = v } diff -r 5158e68dfc6b -r 383e08728219 rpc-light/rpc.mli --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000 @@ -0,0 +1,58 @@ +(* + * 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. + *) + +(** {2 Value} *) + +type t = + Int of int64 + | Bool of bool + | Float of float + | String of string + | Enum of t list + | Dict of (string * t) list + | Null + +val to_string : t -> string + +(** {2 Basic constructors} *) + +val int64_of_rpc : t -> int64 +val rpc_of_int64 : int64 -> t + +val bool_of_rpc : t -> bool +val rpc_of_bool : bool -> t + +val float_of_rpc : t -> float +val rpc_of_float : float -> t + +val string_of_rpc : t -> string +val rpc_of_string : string -> t + +val t_of_rpc : t -> t +val rpc_of_t : t -> t + +(** {2 Calls} *) + +type callback = string list -> t -> unit + +type call = { name : string; params : t list } + +val call : string -> t list -> call + +(** {2 Responses} *) + +type response = { success : bool; contents : t } + +val success : t -> response +val failure : t -> response diff -r 5158e68dfc6b -r 383e08728219 rpc-light/xmlrpc.ml --- a/rpc-light/xmlrpc.ml Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/xmlrpc.ml Fri Jan 08 13:47:46 2010 +0000 @@ -13,6 +13,7 @@ *) open Printf +open Rpc let debug = ref false let debug (fmt: ('a, unit, string, unit) format4) : 'a = @@ -31,32 +32,35 @@ s let rec add_value f = function - | `Int i -> - f "<value><i4>"; + | Null -> + f "<value><nil/></value>" + + | Int i -> + f "<value>"; f (Int64.to_string i); - f "</i4></value>" + f "</value>" - | `Bool b -> - f "<value><bool>"; - f (string_of_bool b); - f "</bool></value>" + | Bool b -> + f "<value><boolean>"; + f (if b then "1" else "0"); + f "</boolean></value>" - | `Float d -> + | Float d -> f "<value><double>"; - f (string_of_float d); + f (Printf.sprintf "%g" d); f "</double></value>" - | `String s -> - f "<value><string>"; + | String s -> + f "<value>"; f (check s); - f "</string></value>" + f "</value>" - | `List a -> + | Enum l -> f "<value><array><data>"; - List.iter (add_value f) a; + List.iter (add_value f) l; f "</data></array></value>" - | `Dict s -> + | Dict d -> let add_member (name, value) = f "<member><name>"; f name; @@ -65,11 +69,8 @@ f "</member>" in f "<value><struct>"; - List.iter add_member s; + List.iter add_member d; f "</struct></value>" - - | `None -> - f "<value><string>nil</string></value>" let to_string x = let buf = Buffer.create 128 in @@ -82,13 +83,13 @@ let add = B.add_string buf in add "<?xml version=\"1.0\"?>"; add "<methodCall><methodName>"; - add (check call.Rpc.name); + add (check call.name); add "</methodName><params>"; List.iter (fun p -> add "<param>"; add (to_string p); add "</param>" - ) call.Rpc.params; + ) call.params; add "</params></methodCall>"; B.contents buf @@ -96,7 +97,7 @@ let module B = Buffer in let buf = B.create 256 in let add = B.add_string buf in - let v = `Dict [ (if response.Rpc.success then "success" else "failure"), response.Rpc.contents ] in + let v = if response.success then response.contents else Dict [ "failure", response.contents ] in add "<?xml version=\"1.0\"?><methodResponse><params><param>"; add (to_string v); add "</param></params></methodResponse>"; @@ -123,7 +124,7 @@ | `El_end -> begin match tags with | [] -> - Buffer.add_string buf "</>"; + Buffer.add_string buf "<?/>"; aux tags | h :: t -> Buffer.add_string buf "</"; @@ -146,7 +147,7 @@ module Parser = struct - (* Specific helpers *) + (* Helpers *) let get_data input = match Xmlm.input input with | `Data d -> d @@ -192,44 +193,20 @@ List.rev !r - (* Basic constructors *) - let make_int ?callback accu data : Rpc.Val.t = - let r = `Int (Int64.of_string data) in + (* Constructors *) + let make fn ?callback accu data = + let r = fn 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 + let make_null = make (fun () -> Null) + let make_int = make (fun data -> Int (Int64.of_string data)) + let make_bool = make (fun data -> Bool (if data = "1" then true else false)) + let make_float = make (fun data -> Float (float_of_string data)) + let make_string = make (fun data -> String data) + let make_enum = make (fun data -> Enum data) + let make_dict = make (fun data -> Dict data) (* General parser functions *) let rec of_xml ?callback accu input = @@ -240,13 +217,15 @@ | e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); exit (-1) 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 + | "int" + | "i4" -> make_int ?callback accu (get_data input) + | "boolean" -> make_bool ?callback accu (get_data input) + | "double" -> make_float ?callback accu (get_data input) + | "string" -> make_string ?callback accu (get_data input) + | "array" -> make_enum ?callback accu (data (of_xmls ?callback accu) input) + | "struct" -> make_dict ?callback accu (members (fun name -> of_xml ?callback (name::accu)) input) + | "nil" -> make_null ?callback accu () + | tag -> parse_error tag (Xmlm.peek input) input and of_xmls ?callback accu input = let r = ref [] in @@ -278,7 +257,7 @@ done; ) input ) input; - { Rpc.name = !name; Rpc.params = !params } + call !name (List.rev !params) let response_of_string ?callback str = let input = Xmlm.make_input (`String (0, str)) in @@ -288,11 +267,9 @@ Parser.map_tag "methodResponse" (fun input -> Parser.map_tag "params" (fun input -> Parser.map_tag "param" (fun input -> - let signal = Xmlm.peek input in match Parser.of_xml ?callback [] input with - | `Dict [ "success", v ] -> { Rpc.success = true; Rpc.contents = v } - | `Dict [ "failure", v ] -> { Rpc.success = false; Rpc.contents = v } - | v -> parse_error "response" signal input + | Dict [ "failure", v ] -> failure v + | v -> success v ) input ) input ) input diff -r 5158e68dfc6b -r 383e08728219 rpc-light/xmlrpc.mli --- a/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 @@ -12,8 +12,8 @@ * GNU Lesser General Public License for more details. *) -val to_string : Rpc.Val.t -> string -val of_string : ?callback:Rpc.callback -> string -> Rpc.Val.t +val to_string : Rpc.t -> string +val of_string : ?callback:Rpc.callback -> string -> Rpc.t val string_of_call: Rpc.call -> string val call_of_string: ?callback:Rpc.callback -> string -> Rpc.call diff -r 5158e68dfc6b -r 383e08728219 stdext/META.in --- a/stdext/META.in Fri Jan 08 13:47:46 2010 +0000 +++ b/stdext/META.in Fri Jan 08 13:47:46 2010 +0000 @@ -1,5 +1,5 @@ version = "@VERSION@" description = "Stdext - Common stdlib extensions" -requires = "unix,uuid,bigarray,rpc-light,jsonrpc" +requires = "unix,uuid,bigarray,rpc-light.json" archive(byte) = "stdext.cma" archive(native) = "stdext.cmxa" 17 files changed, 674 insertions(+), 549 deletions(-) forking_executioner/Makefile | 4 rpc-light/META | 34 +++ rpc-light/META-jsonrpc | 4 rpc-light/META-rpc-light | 11 - rpc-light/META-xmlrpc | 5 rpc-light/Makefile | 70 ++----- rpc-light/examples/Makefile | 2 rpc-light/examples/all_types.ml | 86 +++++---- rpc-light/jsonrpc.ml | 94 ++++----- rpc-light/jsonrpc.mli | 4 rpc-light/p4_rpc.ml | 369 +++++++++++++++++++++++++++++++++++++++ rpc-light/pa_rpc.ml | 291 ------------------------------ rpc-light/rpc.ml | 68 ++++--- rpc-light/rpc.mli | 58 ++++++ rpc-light/xmlrpc.ml | 117 ++++-------- rpc-light/xmlrpc.mli | 4 stdext/META.in | 2 Attachment:
xen-api-libs.hg-17.patch _______________________________________________ xen-api mailing list xen-api@xxxxxxxxxxxxxxxxxxx http://lists.xensource.com/mailman/listinfo/xen-api
|
 |
Lists.xenproject.org is hosted with RackSpace, monitoring our |