Rpc-light is a camlp4 library to easily marshall and unmarshall ML types to and from different RPC values (at the moment, only XML-RPC conversions are implemented).
$(MAKE) -C log
$(MAKE) -C sha1
$(MAKE) -C xml-light2
+ $(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
installxen:
$(MAKE) -C mmap install
$(MAKE) -C log uninstall
$(MAKE) -C sha1 uninstall
$(MAKE) -C xml-light2 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
rm -f $(OUTPUT_API_PKG)
cleanxen:
--- /dev/null
+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
--- /dev/null
+version = "0.1"
+description = "XML-RPC marshalling/unmarshalling"
+requires = "xml-light2"
+archive(byte) = "xmlrpc.cma"
+archive(native) = "xmlrpc.cmxa"
OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
-OCAMLFLAGS = -annot -g
-PACKS = xmlm
+OCAMLFLAGS = -annot
-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
+ICAMLP4=-I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv)
.PHONY: all clean
-all: $(TARGETS)
+all: pa_rpc.cma xmlrpc.cma xmlrpc.cmxa
-pa_rpc.cma: rpc.cmo p4_rpc.cmo pa_rpc.cmo
+pa_rpc.cma: rpc.cmo pa_rpc.cmo
$(OCAMLC) -a $(ICAMLP4) -o $@ $^
-pa_rpc.cmo: pa_rpc.ml p4_rpc.cmo
- $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
+xmlrpc.cmxa: rpc.cmx xmlrpc.cmx
+ $(OCAMLOPT) -a -o $@ $^
-p4_rpc.cmo: p4_rpc.ml rpc.cmo
- $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
+xmlrpc.cma: rpc.cmo xmlrpc.cmo
+ $(OCAMLC) -a -o $@ $^
+
+
+xmlrpc.cmx: xmlrpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -c -I ../xml-light2 -o $@ $<
+
+xmlrpc.cmo: xmlrpc.ml
+ $(OCAMLC) $(OCAMLFLAGES) -c -I ../xml-light2 -o $@ $<
-%.o %.cmx: %.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-%.cmo: %.ml
- $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
+rpc.cmx: rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
+
+rpc.cmo: rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+
+pa_rpc.cmo: pa_rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
-%.cmi: %.mli %.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
.PHONY: install
-install: INSTALL_PATH = $(DESTDIR)$(shell ocamlfind printconf destdir)
-install: all
- ocamlfind install -destdir $(INSTALL_PATH) rpc-light META $(TARGETS)
+install: rpc.cmi pa_rpc.cma xmlrpc.cma xmlrpc.cmxa
+ cp META-xmlrpc META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) xmlrpc META xmlrpc.cma xmlrpc.cmxa xmlrpc.cmi rpc.cmi xmlrpc.cmx rpc.cmx xmlrpc.a xmlrpc.o
+ cp META-rpc-light META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) rpc-light META pa_rpc.cma pa_rpc.cmi
+ rm META
.PHONY: uninstall
uninstall:
+ ocamlfind remove xmlrpc
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
+ rm -f *.cmo *.cmx *.cma *.cmxa *.annot *.o *.cmi *.a
\ No newline at end of file
OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
-OCAMLFLAGS = -annot -g
+OCAMLFLAGS = -annot
-PACKS = rpc-light
-EXAMPLES = \
- all_types \
- phantom \
- xapi \
- encoding \
- dict \
- variants
+PACKS = xmlrpc
+EXAMPLES = all_types
EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
$(OCAMLOPT) -linkpkg -package $(PACKS) -o $@ $<
%.cmx: %.ml
- $(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) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $@.ml
+ $(OCAMLOPT) -package $(PACKS),rpc-light.syntax -syntax camlp4o -c -o $@ $<
clean:
- rm -f *.cmx *.cmi *.cmo *.cmxa *.o $(EXECS)
+ rm -f *.cmx *.cmi *.cmo *.cmxa *.o $(EXECS)
\ No newline at end of file
-(*
- * 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.
- *)
-
type t = Foo of int | Bar of (int * float) with rpc
-module M = struct
- type m = t with rpc
-end
-
-type 'a x = {
- foo: M.m;
+type x = {
+ foo: t;
bar: string;
gna: float list;
f1: (int option * bool list * float list list) option;
f2: (string * string list) array;
f3: int32;
f4: int64;
- f5: int;
- f6: (unit * char) list;
- f7: 'a list;
- f8: (string, t) Hashtbl.t;
- progress: int array;
} with rpc
let _ =
- let x = {
+ let x1 = {
foo= Foo 3;
- bar= "ha ha";
+ bar= "foo";
gna=[1.; 2.; 3.; 4. ];
f2 = [| "hi",["hi"]; "hou",["hou";"hou"]; "foo", ["b";"a";"r"] |];
- f1 = Some (None, [true], [[1.]; [2.;3.]]);
+ f1 = None;
f3 = Int32.max_int;
- f4 = Int64.max_int;
- f5 = max_int;
- f6 = [ (),'a' ; (),'b' ; (),'c'; (),'d' ; (),'e' ];
- f7 = [ Foo 1; Foo 2; Foo 3 ];
- f8 = Hashtbl.create 0;
- progress = [| 0; 1; 2; 3; 4; 5 |];
+ f4 = Int64.max_int
} in
-
- Hashtbl.add x.f8 "hello" (Foo 5);
- Hashtbl.add x.f8 "there" (Bar (5,0.5));
-
- (* Testing basic marshalling/unmarshalling *)
-
- let rpc = rpc_of_x M.rpc_of_m x in
-
- 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"], Rpc.Int i -> Printf.printf "Progress: %Ld\n" i
- | _ -> ()
- 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 "\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);*)
-
- (* 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 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 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 "\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 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 "\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 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 "\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);
-
- let print_hashtbl h =
- Hashtbl.iter (fun k v -> Printf.printf "key=%s v=%s\n" k (match v with | Foo x -> Printf.sprintf "Foo (%d)" x | Bar (x,y) -> Printf.sprintf "Bar (%d,%f)" x y)) h
- in
-
- Printf.printf "Original hashtbl:\n";
- print_hashtbl x.f8;
- Printf.printf "Testing xml Hashtbl representation:\n";
- print_hashtbl x_xml.f8;
- Printf.printf "Testing json Hashtbl representation:\n";
- print_hashtbl x_json.f8
-
+ 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)
-(*
- * 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.
- *)
+(* -pp camlp4orf *)
open Camlp4
open PreCast
open Ast
+open Syntax
-open Pa_type_conv
+(* utils *)
-let _ =
- add_generator "rpc" (fun tds ->
- let _loc = loc_of_ctyp tds in
- <:str_item< $P4_rpc.gen tds$ >>)
+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.Value.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< [< $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$ -> Rpc.Array [ Rpc.String $str:n$ ] >>
+ | Some t ->
+ <:match_case< $uid:n$ $new_pid$ -> Rpc.Array [ Rpc.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 []
+ ] >>
+
+ | <: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
+ Rpc.Array $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$) >>
+
+ | <: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$))
+ >>
+
+ | <: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< Rpc.Struct $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.t >>
+ []
+
+end
+
+(* conversion Rpc.Value.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< raise (Parse_error( $str:expected^" 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$ ] >>
+
+ | <:ctyp< int >> ->
+ <:expr< match $id$ with [ Rpc.Int x -> 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$ ] >>
+
+ | <:ctyp< int64 >> ->
+ <:expr< match $id$ with [ Rpc.String x -> Int64.of_string x | $parg$ -> $parse_error "String(int64)" arg$ ] >>
+
+ | <:ctyp< float >> ->
+ <:expr< match $id$ with [ Rpc.Double x -> x | $parg$ -> $parse_error "Double(flaot)" arg$ ] >>
+
+ | <:ctyp< char >> ->
+ <:expr< match $id$ with [ Rpc.String x -> x.[0] | $parg$ -> $parse_error "Char(string)" arg$ ] >>
+
+ | <:ctyp< string >> ->
+ <:expr< match $id$ with [ Rpc.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$ ] >>
+
+ | <: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< Rpc.Array [ Rpc.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$ >>
+ ) decomp
+ @ [ <:match_case< $parg$ -> $parse_error "Array[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$
+ ] >>
+
+ | <: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 [
+ Rpc.Array $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$
+ ] >>
+
+ | <:ctyp< list $t$ >> ->
+ let new_id, new_pid = new_id _loc in
+ <:expr< match $id$ with [
+ Rpc.Array $new_pid$ ->
+ let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in
+ List.map __fn__ $new_id$
+ | $parg$ -> $parse_error "Array[_]" arg$
+ ] >>
+
+ | <:ctyp< array $t$ >> ->
+ let new_id, new_pid = new_id _loc in
+ <:expr< match $id$ with [
+ Rpc.Array $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$
+ ] >>
+
+ | <: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 [
+ Rpc.Struct $new_pid$ -> $biList_to_expr _loc bindings final_expr$
+ | $parg$ -> $parse_error "Struct(_)" 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.t);
+ value rec $process_type_declaration _loc Rpc_of_ML.process ctyp$;
+ value rec $process_type_declaration _loc ML_of_rpc.process ctyp$
+ >>)
-(*
- * 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.
- *)
-
-let debug = ref false
-let set_debug x = debug := x
-let get_debug () = !debug
-
-type t =
- | Int of int64
+(* From http://www.xmlrpc.com/spec *)
+type t =
+ | Int of int
| Bool of bool
- | Float of float
| String of string
- | Enum of t list
- | Dict of (string * t) list
- | Null
-
-exception Runtime_error of string * t
-exception Runtime_exception of string * string
-
-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 rpc_of_t x = x
-let rpc_of_int64 i = Int i
-let rpc_of_int32 i = Int (Int64.of_int32 i)
-let rpc_of_int i = Int (Int64.of_int i)
-let rpc_of_bool b = Bool b
-let rpc_of_float f = Float f
-let rpc_of_string s = String s
-let rpc_of_unit () = Null
-
-let t_of_rpc x = x
-let int64_of_rpc = function
- | Int i -> i
- | String s -> Int64.of_string s
- | _ -> failwith "int64_of_rpc"
-let int32_of_rpc = function
- | Int i -> Int64.to_int32 i
- | String s -> Int32.of_string s
- | _ -> failwith "int32_of_rpc"
-let int_of_rpc = function
- | Int i -> Int64.to_int i
- | String s -> int_of_string s
- | _ -> failwith "int_of_rpc"
-let bool_of_rpc = function Bool b -> b | _ -> failwith "bool_of_rpc"
-let float_of_rpc = function
- | Float f -> f
- | String s -> float_of_string s
- | _ -> failwith "float_of_rpc"
-let string_of_rpc = function String s -> s | _ -> failwith "string_of_rpc"
-let unit_of_rpc = function Null -> () | _ -> failwith "unit_of_rpc"
-
-type callback = string list -> t -> unit
-
-type call = {
- name: string;
- params: t list;
-}
-
-let call name params = { name = name; params = params }
-
-let string_of_call call =
- sprintf "-> %s(%s)" call.name (String.concat "," (List.map to_string call.params))
-
-type response = {
- success: bool;
- contents: t;
-}
-
-let string_of_response response =
- sprintf "<- %s(%s)" (if response.success then "success" else "failure") (to_string response.contents)
-
-let success v = { success = true; contents = v }
-let failure v = { success = false; contents = v }
+ | Double of float
+ | Struct of (string * t) list
+ | Array of t list
-(*
- * 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.
- *)
-
open Printf
-open Rpc
let debug = ref false
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 *)
-
-(* The XML-RPC is not very clear about what characters can be in a string value ... *)
-let encode s =
- let n = String.length s in
- let aux = function
- | '>' -> Some ">"
- | '<' -> Some "<"
- | '&' -> Some "&"
- | '"' -> Some """
- | c when (c >= '\x20' && c <= '\xff') || c = '\x09' || c = '\x0a' || c = '\x0d'
- -> None
- | _ -> Some "" in
- let need_encoding =
- let b = ref false in
- let i = ref 0 in
- while not !b && !i < n-1 do
- b := aux s.[ !i ] <> None;
- incr i;
- done;
- !b in
- if need_encoding then begin
- let buf = Buffer.create 0 in
- let m = ref 0 in
- for i = 0 to n-1 do
- match aux s.[i] with
- | None -> ()
- | Some n ->
- Buffer.add_substring buf s !m (i - !m);
- Buffer.add_string buf n;
- m := i + 1
- done;
- Buffer.contents buf
- end else
- s
-
-let rec add_value f = function
- | Null ->
- f "<value><nil/></value>"
-
- | Int i ->
- f "<value>";
- f (Int64.to_string i);
- f "</value>"
-
- | Bool b ->
- f "<value><boolean>";
- f (if b then "1" else "0");
- f "</boolean></value>"
-
- | Float d ->
- f "<value><double>";
- f (Printf.sprintf "%g" d);
- f "</double></value>"
-
- | String s ->
- f "<value>";
- f (encode s);
- f "</value>"
-
- | Enum l ->
- f "<value><array><data>";
- List.iter (add_value f) l;
- f "</data></array></value>"
-
- | Dict d ->
- let add_member (name, value) =
- f "<member><name>";
- f name;
- f "</name>";
- add_value f value;
- f "</member>"
- in
- f "<value><struct>";
- List.iter add_member d;
- f "</struct></value>"
-
-let to_string x =
- let buf = Buffer.create 128 in
- add_value (Buffer.add_string buf) x;
- Buffer.contents buf
-
-let to_a ~empty ~append x =
- let buf = empty () in
- add_value (fun s -> append buf s) x;
- buf
-
-let string_of_call call =
- let module B = Buffer in
- let buf = B.create 1024 in
- let add = B.add_string buf in
- add "<?xml version=\"1.0\"?>";
- add "<methodCall><methodName>";
- add (encode call.name);
- add "</methodName><params>";
- List.iter (fun p ->
- add "<param>";
- add (to_string p);
- add "</param>"
- ) call.params;
- add "</params></methodCall>";
- B.contents buf
-
-let add_response add response =
- let v = if response.success then
- Dict [ "Status", String "Success"; "Value", response.contents ]
- else
- Dict [ "Status", String "Failure"; "ErrorDescription", response.contents ] in
- add "<?xml version=\"1.0\"?><methodResponse><params><param>";
- add (to_string v);
- add "</param></params></methodResponse>"
-
-let string_of_response response =
- let module B = Buffer in
- let buf = B.create 256 in
- let add = B.add_string buf in
- add_response add response;
- B.contents buf
-
-let a_of_response ~empty ~append response =
- let buf = empty () in
- let add s = append buf s in
- add_response add response;
- buf
-
-exception Parse_error of string * string * Xmlm.input
-
-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
-
-let pretty_string_of_error got expected input =
- sprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" got expected (debug_input input)
-
-let parse_error got expected input =
- raise (Parse_error (got, expected, input))
-
-module Parser = struct
-
- let is_empty s =
- let is_empty = ref true in
- for i = 0 to (String.length s - 1)
- do
- if s.[i] <> '\n' && s.[i] <> ' ' && s.[i] <> '\t' then is_empty := false
- done;
- !is_empty
-
- let rec skip_empty input =
- match Xmlm.peek input with
- | `Data d when is_empty d -> let _ = Xmlm.input input in skip_empty input
- | _ -> ()
-
- (* Helpers *)
- let get_data input =
- match Xmlm.input input with
- | `Dtd _ -> parse_error "dtd" "data" input
- | `Data d -> d
- | `El_start ((_,tag),_) -> parse_error (sprintf "open_tag(%s)" tag) "data" input
- | `El_end -> ""
-
- let rec open_tag input =
- match Xmlm.input input with
- | `Dtd _ -> open_tag input
- | `El_start ((_,tag),_) -> tag
- | `Data d when is_empty d -> open_tag input
- | `Data d -> parse_error (sprintf "data(%s)" (String.escaped d)) "open_tag" input
- | `El_end -> parse_error "close_tag" "open_tag" input
-
- let rec close_tag tag input =
- match Xmlm.input input with
- | `Dtd _ -> parse_error "dtd" (sprintf "close_tag(%s)" tag) input
- | `El_end -> ()
- | `El_start ((_,t),_) -> parse_error (sprintf "open_tag(%s)" t) (sprintf "close_tag(%s)" tag) input
- | `Data d when is_empty d -> close_tag tag input
- | `Data d -> parse_error (sprintf "data(%s)" (String.escaped d)) (sprintf "close_tag(%s)" tag) input
-
- let empty_tag input = function
- | "string" -> String ""
- | "array" -> Enum []
- | "struct" -> Dict []
- | "nil" -> Null
- | "value" -> String ""
- | tag -> parse_error (sprintf "empty_%s" tag) tag input
-
- let map_tags f input =
- let tag = open_tag input in
- let r =
- if Xmlm.peek input = `El_end then
- empty_tag input tag
- else
- f input tag in
- close_tag 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 tag input;
- r
- end else
- parse_error (sprintf "open_tag(%s)" t) (sprintf "open_tag(%s)" tag) input
-
- let name input = map_tag "name" get_data input
- let data f input = map_tag "data" f input
- let value f input =
- let t = open_tag input in
- if t = "value" then begin
- let r =
- match Xmlm.peek input with
- | `El_end -> Rpc.String ""
- | `Data d ->
- let _ = Xmlm.input input in
- if is_empty d && match Xmlm.peek input with `El_start _ -> true | _ -> false then
- f input
- else
- Rpc.String d
- | _ -> f input in
- close_tag "value" input;
- r
- end else
- parse_error "open_tag(value)" (sprintf "open_tag(%s)" t) 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
- skip_empty input;
- while Xmlm.peek input <> `El_end do
- r := map_tag "member" g input :: !r;
- skip_empty input;
- done;
- List.rev !r
-
- (* 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_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 =
- try value (map_tags (basic_types ?callback accu)) input
- with
- | Xmlm.Error ((a,b), e) as exn->
- eprintf "Characters %i--%i: %s\n%!" a b (Xmlm.error_message e);
- raise exn
- | e ->
- eprintf "%s\n%!" (Printexc.to_string e);
- raise e
-
- and basic_types ?callback accu input = function
- | "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 (sprintf "open_tag(%s)" tag) "open_tag(int/i4/boolean/double/string/array/struct/nil)" input
-
- and of_xmls ?callback accu input =
- let r = ref [] in
- skip_empty input;
- while Xmlm.peek input <> `El_end do
- r := of_xml ?callback accu input :: !r;
- skip_empty input;
- done;
- List.rev !r
-end
-
-let of_string ?callback str =
- 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
-
-let of_a ?callback ~next_char b =
- let aux () =
- try
- let c = next_char b in
- int_of_char c
- with _ -> raise End_of_file in
- let input = Xmlm.make_input (`Fun aux) in
- Parser.of_xml ?callback [] input
-
-let call_of_string ?callback str =
- let input = Xmlm.make_input (`String (0, str)) in
- begin match Xmlm.peek input with
- | `Dtd _ -> ignore (Xmlm.input input)
- | _ -> () end;
- let name = ref "" in
- let params = ref [] in
- Parser.map_tag "methodCall" (fun input ->
- name := Parser.map_tag "methodName" Parser.get_data input;
- Parser.map_tag "params" (fun input ->
- Parser.skip_empty input;
- while Xmlm.peek input <> `El_end do
- Parser.map_tag "param" (fun input -> params := (Parser.of_xml ?callback [] input) :: !params) input;
- Parser.skip_empty input;
- done;
- ) input
- ) input;
- call !name (List.rev !params)
-
-let response_of_fault ?callback input =
- Parser.map_tag "fault" (fun input ->
- match Parser.of_xml ?callback [] input with
- | Dict d ->
- let fault_code = List.assoc "faultCode" d in
- let fault_string = List.assoc "faultString" d in
- failure ( Rpc.Enum [ String "fault"; fault_code; fault_string ] )
- | r -> parse_error (to_string r) "fault" input
- ) input
-
-let response_of_success ?callback input =
- Parser.map_tag "params" (fun input ->
- Parser.map_tag "param" (fun input ->
- match Parser.of_xml ?callback [] input with
- | Dict d ->
- if List.mem_assoc "Status" d && List.assoc "Status" d = String "Success" && List.mem_assoc "Value" d then
- success (List.assoc "Value" d)
- else if List.mem_assoc "Status" d && List.assoc "Status" d = String "Failure" && List.mem_assoc "ErrorDescription" d then
- failure (List.assoc "ErrorDescription" d)
- else
- success (Dict d)
- | v -> success v
- ) input
- ) input
-
-let response_of_input ?callback input =
- begin match Xmlm.peek input with
- | `Dtd _ -> ignore (Xmlm.input input)
- | _ -> () end;
- Parser.map_tag "methodResponse" (fun input ->
- Parser.skip_empty input;
- match Xmlm.peek input with
- | `El_start ((_,"params"),_) -> response_of_success ?callback input
- | `El_start ((_,"fault"),_) -> response_of_fault ?callback input
- | `El_start ((_,tag),_) -> parse_error (sprintf "open_tag(%s)" tag) "open_tag(fault/params)" input
- | `Data d -> parse_error (String.escaped d) "open_tag(fault/params)" input
- | `El_end -> parse_error "close_tag" "open_tag(fault/params)" input
- | `Dtd _ -> parse_error "dtd" "open_tag(fault/params)" input
- ) input
-
-let response_of_string ?callback str =
- let input = Xmlm.make_input (`String (0, str)) in
- response_of_input ?callback input
-
-let response_of_in_channel ?callback chan =
- let input = Xmlm.make_input (`Channel chan) in
- response_of_input ?callback input
+let rec to_string = function
+ | Rpc.Int i -> sprintf "<value><int>%i</int></value>" i
+ | Rpc.Bool b -> sprintf "<value><bool>%b</bool></value>" b
+ | Rpc.String s -> sprintf "<value><string>%s</string></value>" s
+ | Rpc.Double d -> sprintf "<value><double>%f</double></value>" d
+ | Rpc.Array a -> sprintf "<value><array><data>%s</data></array></value>" (String.concat "" (List.map to_string a))
+ | Rpc.Struct f ->
+ let members =
+ List.map (fun (name, value) -> sprintf "<member><name>%s</name>%s</member>" name (to_string value)) f in
+ sprintf "<value><struct>%s</struct></value>" (String.concat "" members)
+
+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)
projects / xcp / xen-api-libs.git / commitdiff