Permalink
Browse files

Use custom marshallers to make sure rpc-light generated xml is

identical to xml-light2

Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
  • Loading branch information...
1 parent cc8f80e commit ea10cc8e6a9b25ce636ca097fba68343efb7e506 @jonludlam jonludlam committed Nov 11, 2012
View
4 OMakefile
@@ -91,7 +91,9 @@ if $(not $(defined-env BINDIR))
if $(not $(defined-env SBINDIR))
SBINDIR=/opt/xensource/bin
export
-
+if $(not $(defined-env UDEVDIR))
+ UDEVDIR=/etc/udev
+ export
XEN_CFLAGS=-I$(XEN_ROOT)/usr/include
XEN_OCAML_LINK_FLAGS=-cclib -L$(XEN_ROOT)/usr/$(LIBDIR)
View
2 ocaml/idl/ocaml_backend/OMakefile
@@ -16,7 +16,7 @@ CAMLP4_FILES = event_types
UseCamlp4(rpc-light.syntax, $(CAMLP4_FILES))
# only gen_api requires datamodel library:
-GEN_API_FILES = gen_api genOCaml ref ocaml_syntax gen_db_actions gen_db_check gen_empty_custom gen_client gen_server gen_common gen_rbac ../../database/escaping locking ../api_lowlevel gen_api_main ../datamodel ../constants ../api_errors ../api_messages ../datamodel_utils ../datamodel_values ocaml_utils ../datamodel_types ../dm_api $(AUTOGEN_HELPER_DIR)/string_marshall_helper
+GEN_API_FILES = gen_api gen_test genOCaml ref ocaml_syntax gen_db_actions gen_db_check gen_empty_custom gen_client gen_server gen_common gen_rbac ../../database/escaping locking ../api_lowlevel gen_api_main ../datamodel ../constants ../api_errors ../api_messages ../datamodel_utils ../datamodel_values ocaml_utils ../datamodel_types ../dm_api $(AUTOGEN_HELPER_DIR)/string_marshall_helper
OCamlProgram(gen_api_main, $(GEN_API_FILES))
OCamlDocProgram(gen_api_main, $(GEN_API_FILES))
View
36 ocaml/idl/ocaml_backend/gen_api.ml
@@ -22,6 +22,26 @@ module O = Ocaml_syntax
let print s = output_string stdout (s^"\n")
+let overrides = [
+ "vm_operations_to_string_map",(
+ "let rpc_of_vm_operations_to_string_map x = Rpc.Dict (List.map (fun (x,y) -> (match rpc_of_vm_operations x with Rpc.String x -> x | _ -> failwith \"Marshalling error\"), Rpc.String y) x)\n" ^
+ "let vm_operations_to_string_map_of_rpc x = match x with Rpc.Dict l -> List.map (function (x,y) -> vm_operations_of_rpc (Rpc.String x), string_of_rpc y) l | _ -> failwith \"Unmarshalling error\"\n");
+ "bond_mode",(
+ "let rpc_of_bond_mode x = match x with `balanceslb -> Rpc.String \"balance-slb\" | `activebackup -> Rpc.String \"active-backup\" | `lacp -> Rpc.String \"lacp\"\n"^
+ "let bond_mode_of_rpc x = match x with Rpc.String \"balance-slb\" -> `balanceslb | Rpc.String \"active-backup\" -> `activebackup | Rpc.String \"lacp\" -> `lacp | _ -> failwith \"Unmarshalling error in bond-mode\"\n");
+ "int64_to_float_map",(
+ "let rpc_of_int64_to_float_map x = Rpc.Dict (List.map (fun (x,y) -> Int64.to_string x, Rpc.Float y) x)\n" ^
+ "let int64_to_float_map_of_rpc x = match x with Rpc.Dict x -> List.map (fun (x,y) -> Int64.of_string x, float_of_rpc y) x | _ -> failwith \"Unmarshalling error\"");
+ "int64_to_int64_map",(
+ "let rpc_of_int64_to_int64_map x = Rpc.Dict (List.map (fun (x,y) -> Int64.to_string x, Rpc.Int y) x)\n" ^
+ "let int64_to_int64_map_of_rpc x = match x with Rpc.Dict x -> List.map (fun (x,y) -> Int64.of_string x, int64_of_rpc y) x | _ -> failwith \"Unmarshalling error\"");
+ "int64_to_string_set_map",(
+ "let rpc_of_int64_to_string_set_map x = Rpc.Dict (List.map (fun (x,y) -> Int64.to_string x, rpc_of_string_set y) x)\n" ^
+ "let int64_to_string_set_map_of_rpc x = match x with Rpc.Dict x -> List.map (fun (x,y) -> Int64.of_string x, string_set_of_rpc y) x | _ -> failwith \"Unmarshalling error\"");
+
+]
+
+
(** Generate a single type declaration for simple types (eg not containing references to record objects) *)
let gen_non_record_type highapi tys =
let rec aux accu = function
@@ -33,10 +53,12 @@ let gen_non_record_type highapi tys =
| DT.Record _ :: t
| DT.Map (_, DT.Record _) :: t
| DT.Set (DT.Record _) :: t -> aux accu t
- | ty :: t -> aux (sprintf "%s = %s" (OU.alias_of_ty ty) (OU.ocaml_of_ty ty) :: accu) t in
- match aux [] tys with
- | [] -> []
- | h::t -> sprintf "type %s" h :: List.map (sprintf "and %s") t
+ | ty :: t ->
+ let alias = OU.alias_of_ty ty in
+ if List.mem_assoc alias overrides
+ then aux ((sprintf "type %s = %s\n%s\n" alias (OU.ocaml_of_ty ty) (List.assoc alias overrides))::accu) t
+ else aux (sprintf "type %s = %s with rpc" (OU.alias_of_ty ty) (OU.ocaml_of_ty ty) :: accu) t in
+ aux [] tys
(** Generate a list of modules for each record kind *)
let gen_record_type ~with_module highapi tys =
@@ -110,13 +132,13 @@ let gen_client_types highapi =
]; [
"module Date = struct";
" include Date";
- " let rpc_of_iso8601 x = String (Date.to_string x)";
- " let iso8601_of_rpc = function String x -> Date.of_string x | _ -> failwith \"Date.iso8601_of_rpc\"";
+ " let rpc_of_iso8601 x = DateTime (Date.to_string x)";
+ " let iso8601_of_rpc = function String x | DateTime x -> Date.of_string x | _ -> failwith \"Date.iso8601_of_rpc\"";
"end";
]; [
"let on_dict f = function | Rpc.Dict x -> f x | _ -> failwith \"Expected Dictionary\""
];
- gen_non_record_type highapi all_types @ [ "with rpc" ];
+ gen_non_record_type highapi all_types;
gen_record_type ~with_module:true highapi all_types;
O.Signature.strings_of (Gen_client.gen_signature highapi);
[ "module Legacy = struct";
View
4 ocaml/idl/ocaml_backend/gen_api_main.ml
@@ -56,7 +56,7 @@ let _ =
Arg.parse
[
"-mode",
- Arg.Symbol (["client"; "server"; "api"; "db"; "actions"; "sql"; "rbac"],
+ Arg.Symbol (["client"; "server"; "api"; "db"; "actions"; "sql"; "rbac"; "test"],
fun x -> mode := Some x),
"Choose which file to output";
"-filter",
@@ -89,4 +89,6 @@ let _ =
Gen_api.gen_custom_actions api
| Some "rbac" ->
Gen_api.gen_rbac api
+ | Some "test" ->
+ Gen_test.gen_test api
| Some x -> Printf.eprintf "Didn't recognise mode: %s\n" x
View
75 ocaml/idl/ocaml_backend/gen_test.ml
@@ -0,0 +1,75 @@
+(*
+ * 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 Listext
+open Printf
+
+module DT = Datamodel_types
+module DU = Datamodel_utils
+module OU = Ocaml_utils
+
+module O = Ocaml_syntax
+
+let print s = output_string stdout (s^"\n")
+
+let rec gen_test_type highapi ty =
+ let rec aux = function
+ | DT.String -> "\"teststring\""
+ | DT.Int -> "123456789123456789L"
+ | DT.Float -> "0.123456789"
+ | DT.Bool -> "true"
+ | DT.DateTime -> "(Date.of_string \"20120101T00:00:00Z\")"
+ | DT.Enum (_,(x,_)::_) -> Printf.sprintf "(%s)" (OU.constructor_of x)
+ | DT.Set (DT.Enum (x,y)) ->
+ Printf.sprintf "[ %s ]"
+ (String.concat ";"
+ (List.map (fun (x,y) -> OU.constructor_of x) y))
+ | DT.Set x -> Printf.sprintf "[ %s ]" (aux x)
+ | DT.Map (x,y) -> Printf.sprintf "[ (%s,%s) ]" (aux x) (aux y)
+ | DT.Ref x -> Printf.sprintf "(Ref.of_string \"OpaqueRef:foo\")"
+ | DT.Record x -> gen_record_type highapi x
+ | _ -> failwith "Invalid type"
+ in
+ aux ty
+
+(** Generate a list of modules for each record kind *)
+and gen_record_type highapi record =
+ let obj_name = OU.ocaml_of_record_name record in
+ let all_fields = DU.fields_of_obj (Dm_api.get_obj_by_name highapi ~objname:record) in
+ let field fld = OU.ocaml_of_record_field (obj_name :: fld.DT.full_name) in
+ let map_fields fn = String.concat "; " (List.map (fun field -> fn field) all_fields) in
+ let regular_def fld = sprintf "%s=%s" (field fld) (gen_test_type highapi fld.DT.ty) in
+ sprintf "{ %s }" (map_fields regular_def)
+
+
+let gen_test highapi =
+ let all_types = DU.Types.of_objects (Dm_api.objects_of_api highapi) in
+ ignore(all_types);
+ List.iter (List.iter print)
+ (List.between [""] [
+ ["open API"];
+ ["let _ ="];
+ List.concat (List.map (fun ty ->
+ [
+ sprintf "let oc = open_out \"rpc-light_%s.xml\" in" (OU.alias_of_ty ty);
+ sprintf "let x = %s in" (gen_test_type highapi ty);
+ sprintf "Printf.fprintf oc \"%%s\" (Xmlrpc.to_string (API.rpc_of_%s x));" (OU.alias_of_ty ty);
+ "close_out oc;";
+ sprintf "let oc = open_out \"xml-light2_%s.xml\" in" (OU.alias_of_ty ty);
+ sprintf "Printf.fprintf oc \"%%s\" (Xml.to_string (API.Legacy.To.%s x));" (OU.alias_of_ty ty);
+ "close_out oc;";
+
+ ]
+ ) all_types)
+ ])
+

0 comments on commit ea10cc8

Please sign in to comment.