SUBDIRS = libs/uuid libs/stdext libs/mmap \
libs/log libs/xc libs/eventchn \
libs/xb libs/xs libs/netdev \
- libs/json libs/json/gen_json_conv libs/json/gen_rpc \
+ libs/json \
common \
+ gen/json_conv gen/rpc \
xenstore xenstored xenops xenvm closeandexec \
xenguest
--- /dev/null
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+GENERATED_FILES = lexer.ml parser.mli parser.ml
+
+gen_json_conv_OBJS = syntax lexer parser codegen gen_json_conv
+gen_json_conv_LIBS = unix.cmxa
+
+ALL_OCAML_OBJS = $(gen_json_conv_OBJS)
+
+OCAML_PROGRAM = gen_json_conv
+PROGRAMS = $(OCAML_PROGRAM)
+
+all: $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+include $(TOPLEVEL)/Makefile.rules
+
--- /dev/null
+.PHONY: clean
+
+GEN_FILES = parser.mli parser.ml lexer.ml
+OCamlGeneratedFiles($(GEN_FILES))
+
+OCAML_OTHER_LIBS[] += unix
+CONV_FILES[] =
+ lexer
+ parser
+ syntax
+ codegen
+ gen_json_conv
+
+JSON_CONV_PROG = gen_json_conv
+JSON_CONV = $(OCamlProgram $(JSON_CONV_PROG), $(CONV_FILES))
+
+.DEFAULT: $(JSON_CONV)
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
+
+.SUBDIRS: tests
+
+export JSON_CONV_PROG JSON_CONV
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Syntax
+open Format
+
+exception Unknown_base_type of string
+
+let known_types = ((ref []) : string list ref)
+let is_known_type ident = List.mem ident !known_types
+let add_known_type ident = known_types := ident :: !known_types
+let reset_known_types () = known_types := []
+
+let base_to_str = function
+ | B_string -> "string" | B_int -> "int" | B_int64 -> "int64"
+ | B_bool -> "bool" | B_ident s -> s
+
+type var = { stem: string; mark: int }
+
+let name_of_var v =
+ match v.mark with
+ | 0 -> Printf.sprintf "%s" v.stem
+ | d -> Printf.sprintf "%s_%d" v.stem d
+
+module Var_env = struct
+ module StringMap = Map.Make (struct type t = string let compare = compare end)
+
+ type name_entry = { cur_mark: int; entries: var list; }
+
+ let new_name_entry = { cur_mark = 0; entries = [] }
+
+ let make_new_var name_entry name =
+ let var = { stem = name; mark = name_entry.cur_mark} in
+ var, { cur_mark = var.mark + 1; entries = var :: name_entry.entries }
+
+ type t = name_entry StringMap.t
+ let new_env = StringMap.empty
+
+ let new_var env full_name =
+ let var, new_entry = make_new_var (try StringMap.find full_name env
+ with Not_found -> new_name_entry) full_name in
+ var, (StringMap.add full_name new_entry env)
+
+ let new_ident_from_name env ?(prefix="") ?(suffix="") stem =
+ new_var env (prefix ^ stem ^ suffix)
+
+ let base_to_stem = function
+ | B_string -> "str" | B_int -> "int" | B_int64 -> "int64"
+ | B_bool -> "bool" | B_ident s -> s
+
+ let complex_type_to_stem = function
+ | C_base b -> base_to_stem b | C_option _ -> "opt" | C_list _ -> "lst"
+ | C_array _ -> "arr" | C_tuple _ -> "tup" | C_record _ -> "rcd"
+ | C_variant _ -> "var"
+
+ let new_ident_from_type env ct =
+ new_ident_from_name env (complex_type_to_stem ct)
+
+ let new_idents_from_types env cts =
+ let vlist, env =
+ List.fold_left (fun (vlist, env) ct ->
+ let v, env' = new_ident_from_type env ct in
+ (v :: vlist), env'
+ ) ([], env) cts in
+ (List.rev vlist), env
+
+ let new_ident_from_var env ?(prefix="") ?(suffix="") var =
+ new_ident_from_name env ~prefix ~suffix var.stem
+
+ let new_idents_from_vars env ?(prefix="") ?(suffix="") vlist =
+ let vlist, env =
+ List.fold_left (fun (vlist, env) v ->
+ let v, env' = new_ident_from_var env ~prefix ~suffix v in
+ (v :: vlist), env'
+ ) ([], env) vlist in
+ (List.rev vlist), env
+end
+
+type rec_type = First | Next
+
+module To = struct
+ let prod_vars_to_str vlist =
+ let elems = List.map name_of_var vlist in
+ String.concat ", " elems
+
+ let to_array_str ?(constr="") vlist =
+ let elems = List.map name_of_var vlist in
+ let constr = if constr = "" then "" else "(string_to_json \"" ^ constr ^ "\"); " in
+ "[| " ^ constr ^ (String.concat "; " elems) ^ " |]"
+
+ let to_object_str fn_list fv_list =
+ let elems = List.map2 (fun f v ->
+ Printf.sprintf "(\"%s\", %s)" f (name_of_var v)
+ ) fn_list fv_list in
+ "[| " ^ (String.concat "; " elems) ^ " |]"
+
+ let to_record_str fnlist fvlist =
+ let fields = List.map2 (fun fn fv ->
+ Printf.sprintf "%s = %s" fn (name_of_var fv)
+ ) fnlist fvlist in
+ "{ " ^ (String.concat "; " fields) ^ " }"
+
+ let rec to_json ff venv inv typ =
+ let v = name_of_var inv in
+ match typ with
+ | C_base bt ->
+ (match bt with
+ | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
+ | _ -> ());
+ fprintf ff "%s_to_json %s" (base_to_str bt) v
+ | C_option optt ->
+ let optv, venv = Var_env.new_ident_from_type venv optt in
+ fprintf ff "(match %s with@," v;
+ fprintf ff "| None -> Json_null@,";
+ fprintf ff "@[<v 8>| Some %s ->@," (name_of_var optv);
+ to_json ff venv optv optt;
+ fprintf ff "@]@,)"
+ | C_list elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let jlistv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jlist" in
+ let jlistvn = name_of_var jlistv in
+ fprintf ff "@[<v 8>let %s = List.map@," jlistvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ to_json ff venv elemv elemt;
+ fprintf ff "@]@,) %s in@]@," v;
+ fprintf ff "Json_array (Array.of_list %s)" jlistvn
+ | C_array elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
+ let jarrayvn = name_of_var jarrayv in
+ fprintf ff "@[<v 8>let %s = Array.map@," jarrayvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ to_json ff venv elemv elemt;
+ fprintf ff "@]@,) %s in@]@," v;
+ fprintf ff "Json_array %s" jarrayvn
+ | C_tuple ctlist ->
+ let cvlist, venv = Var_env.new_idents_from_types venv ctlist in
+ let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" cvlist in
+ let cvtlist = List.combine cvlist ctlist in
+ fprintf ff "(match %s with@," v;
+ fprintf ff "@[<v 8>| %s ->@," (prod_vars_to_str cvlist);
+ List.iter2 (fun letv (cv, ct) ->
+ let_bind ff venv letv cv ct
+ ) letvlist cvtlist;
+ fprintf ff "Json_array %s@]@,)" (to_array_str letvlist)
+ | C_record cls ->
+ let fnlist, ftlist = List.split cls in
+ let fvlist, venv = Var_env.new_idents_from_types venv ftlist in
+ let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" fvlist in
+ fprintf ff "(match %s with@," v;
+ fprintf ff "@[<v 8>| %s ->@," (to_record_str fnlist fvlist);
+ List.iter2 (fun letv (fv, ft) ->
+ let_bind ff venv letv fv ft
+ ) letvlist (List.combine fvlist ftlist);
+ fprintf ff "Json_object %s@]@,)" (to_object_str fnlist letvlist)
+ | C_variant cdlist ->
+ fprintf ff "(match %s with@," v;
+ List.iter (fun cd -> variant ff venv cd) cdlist;
+ fprintf ff ")"
+
+ and variant ff venv (CD_tuple (vname, vtlist)) =
+ let vlist, venv = Var_env.new_idents_from_types venv vtlist in
+ let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" vlist in
+ if List.length vlist = 0 then
+ fprintf ff "@[<v 8>| %s ->@," vname
+ else
+ fprintf ff "@[<v 8>| %s (%s) ->@," vname (prod_vars_to_str vlist);
+ List.iter2 (fun letv (v, vt) ->
+ let_bind ff venv letv v vt
+ ) letvlist (List.combine vlist vtlist);
+ fprintf ff "Json_array %s@]@," (to_array_str ~constr:vname letvlist)
+
+ and let_bind ff venv letv inv typ =
+ fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
+ to_json ff venv inv typ;
+ fprintf ff " in@]@,"
+
+ let def ff venv fn_name typ recd =
+ let fnv, venv = Var_env.new_ident_from_name venv fn_name in
+ let inv, venv = Var_env.new_ident_from_name venv "o" in
+ let decl = match recd with First -> "let rec" | Next -> "and" in
+ fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
+ to_json ff venv inv typ;
+ fprintf ff "@]@,@\n@?"
+end
+
+module From = struct
+ let to_tuple_str ?(constr="") vlist =
+ let elems = List.map name_of_var vlist in
+ let len = List.length elems in
+ (match len with
+ | 0 -> Printf.sprintf "%s" constr
+ | 1 -> Printf.sprintf "%s %s" constr (List.hd elems)
+ | _ -> Printf.sprintf "%s (%s)" constr (String.concat ", " elems))
+
+ let to_record_str fnlist fvlist =
+ let fields = List.map2 (fun fn fv ->
+ Printf.sprintf "%s = %s" fn (name_of_var fv)
+ ) fnlist fvlist in
+ "{ " ^ (String.concat "; " fields) ^ " }"
+
+ let rec of_json ff venv inv typ tname =
+ let v = name_of_var inv in
+ match typ with
+ | C_base bt ->
+ (match bt with
+ | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
+ | _ -> ());
+ fprintf ff "%s_of_json %s" (base_to_str bt) v
+ | C_option optt ->
+ let optv, venv = Var_env.new_ident_from_type venv optt in
+ fprintf ff "(match %s with@," v;
+ fprintf ff "| Json_null -> None@,";
+ fprintf ff "@[<v 8>| %s -> @,Some (" (name_of_var optv);
+ of_json ff venv optv optt tname;
+ fprintf ff ")@]@,)"
+ | C_list elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
+ let oarrayvn = name_of_var oarrayv in
+ fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ of_json ff venv elemv elemt tname;
+ fprintf ff "@]@,) (get_array %s) in@]@," v;
+ fprintf ff "Array.to_list %s" oarrayvn
+ | C_array elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
+ let oarrayvn = name_of_var oarrayv in
+ fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ of_json ff venv elemv elemt tname;
+ fprintf ff "@]@,) (get_array %s) in@]@," v;
+ fprintf ff "%s" oarrayvn
+ | C_tuple ctlist ->
+ let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
+ let jarrayvn = name_of_var jarrayv in
+ let letvlist, venv = Var_env.new_idents_from_types venv ctlist in
+ fprintf ff "let %s = get_array %s in@," jarrayvn v;
+ fprintf ff "check_array_with_length %s %d;@," jarrayvn (List.length ctlist);
+ ignore (List.fold_left (fun indx (letv, ct) ->
+ let inv, venv = Var_env.new_ident_from_name venv "tindx" in
+ fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) jarrayvn indx;
+ let_bind ff venv letv inv ct tname;
+ indx + 1
+ ) 0 (List.combine letvlist ctlist));
+ fprintf ff "%s" (to_tuple_str letvlist)
+ | C_record cls ->
+ let fnlist, ftlist = List.split cls in
+ let letvlist, venv = Var_env.new_idents_from_types venv ftlist in
+ let objtv, venv = Var_env.new_ident_from_name venv v ~suffix:"_ftable" in
+ let objtvn = name_of_var objtv in
+ fprintf ff "let %s = get_object_table %s in@," objtvn v;
+ List.iter2 (fun letv (fn, ft) ->
+ let fvar, venv = Var_env.new_ident_from_name venv ~suffix:"_f" fn in
+ let optional = match ft with C_option _ -> "optional_" | _ -> "" in
+ fprintf ff "let %s = get_%sobject_field %s \"%s\" in@," (name_of_var fvar) optional objtvn fn;
+ let_bind ff venv letv fvar ft tname
+ ) letvlist cls;
+ fprintf ff "%s" (to_record_str fnlist letvlist)
+ | C_variant cdlist ->
+ let consv, venv = Var_env.new_ident_from_name venv "cons" in
+ let consvn = name_of_var consv in
+ let argsv, venv = Var_env.new_ident_from_name venv "args" in
+ let defmatchv, venv = Var_env.new_ident_from_name venv "s" in
+ let defmatchvn = name_of_var defmatchv in
+ fprintf ff "let %s, %s = get_variant_constructor %s in@,"
+ consvn (name_of_var argsv) v;
+ fprintf ff "(match %s with@," consvn;
+ List.iter (fun cd -> variant ff venv argsv cd tname) cdlist;
+ (* need to write a default match case *)
+ fprintf ff "| %s -> raise_unknown_constructor \"%s\" %s@,)"
+ defmatchvn tname defmatchvn
+
+ and variant ff venv argsv (CD_tuple (vname, vtlist)) tname =
+ let argsvn = name_of_var argsv in
+ let vtlen = List.length vtlist in
+ let vlist, venv = Var_env.new_idents_from_types venv vtlist in
+ let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"o_" vlist in
+ fprintf ff "@[<v 8>| \"%s\" ->@," vname;
+ if vtlen > 0 then
+ fprintf ff "check_array_with_length %s %d;@," argsvn (vtlen + 1);
+ ignore (List.fold_left (fun indx (letv, vt) ->
+ let inv, venv = Var_env.new_ident_from_name venv "aindx" in
+ fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) argsvn indx;
+ let_bind ff venv letv inv vt tname;
+ indx + 1
+ ) 1 (List.combine letvlist vtlist));
+ fprintf ff "%s@]@," (to_tuple_str ~constr:vname letvlist)
+
+ and let_bind ff venv letv inv typ tname =
+ fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
+ of_json ff venv inv typ tname;
+ fprintf ff " in@]@,"
+
+ let def ff venv fn_name (tname, typ) recd =
+ let fnv, venv = Var_env.new_ident_from_name venv fn_name in
+ let inv, venv = Var_env.new_ident_from_name venv "j" in
+ let decl = match recd with First -> "let rec" | Next -> "and" in
+ fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
+ of_json ff venv inv typ tname;
+ fprintf ff "@]@,@\n@?"
+end
+
+let generate_to_def ff is_and (tname, trep) =
+ To.def ff Var_env.new_env (tname ^ "_to_json") trep is_and
+
+let generate_from_def ff is_and (tname, trep) =
+ From.def ff Var_env.new_env (tname ^ "_of_json") (tname, trep) is_and
+
+let generate_header ff ifn =
+ let md = Filename.basename (Filename.chop_extension ifn) in
+ let call = String.concat " " (Array.to_list Sys.argv) in
+ fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call;
+ fprintf ff "open Json@\n";
+ fprintf ff "open Json_conv@\n";
+ fprintf ff "open %s@\n@\n" (String.capitalize md)
+
+let generate_one_defn ff td =
+ match td with
+ | [] -> ()
+ | h :: t ->
+ List.iter (fun (tname, _) -> add_known_type tname) td;
+ generate_to_def ff First h;
+ List.iter (generate_to_def ff Next) t;
+ generate_from_def ff First h;
+ List.iter (generate_from_def ff Next) t
+
+let generate defn_list ofn ifn =
+ reset_known_types ();
+ let op_flags = [ Open_wronly ; Open_creat; Open_trunc; Open_text ] in
+ let oc = open_out_gen op_flags 0o444 ofn in
+ let ff = formatter_of_out_channel oc in
+ try
+ generate_header ff ifn;
+ List.iter (generate_one_defn ff) defn_list;
+ close_out oc
+ with Unknown_base_type id ->
+ Printf.eprintf "Error: Unknown base type \"%s\"\n" id;
+ close_out oc;
+ Unix.unlink ofn
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Syntax
+open Parser
+open Lexing
+
+let show_syntax_error e l =
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ l.pos_fname l.pos_lnum (l.pos_cnum - l.pos_bol) in
+ let msg =
+ match e with
+ | Illegal_character c -> Printf.sprintf "Illegal character %c" c
+ | Invalid_ident s -> Printf.sprintf "Invalid/unsupported identifier %s" s
+ | Unsupported_type_constructor s -> Printf.sprintf "Unsupported type constructor %s" s
+ | Unmatched_comment -> Printf.sprintf "Unmatched comment"
+ | Unterminated_comment -> Printf.sprintf "Unterminated comment"
+ in
+ Printf.eprintf "%s: %s\n" loc msg;
+ exit 1
+
+let show_parse_error lexbuf =
+ let lxm = lexeme lexbuf in
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ lexbuf.lex_curr_p.pos_fname lexbuf.lex_curr_p.pos_lnum
+ (lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol) in
+ (match lxm with
+ | "" -> Printf.eprintf "%s: parsing error\n" loc
+ | _ -> Printf.eprintf "%s: parsing error at \"%s\"\n" loc lxm);
+ exit 1
+
+let parse_file file =
+ let f = open_in file in
+ let lexbuf = Lexing.from_channel f in
+ try
+ Lexer.init lexbuf file;
+ Parser.defn_list Lexer.main lexbuf
+ with
+ | Syntax_error (e, l) ->
+ show_syntax_error e l
+ | Parsing.Parse_error ->
+ show_parse_error lexbuf
+
+let default_output_filename f =
+ let dir, base = Filename.dirname f, Filename.basename f in
+ let stem = Filename.chop_extension base in
+ Filename.concat dir (stem ^ "_json_conv.ml")
+
+let () =
+ let input = ref "" in
+ let output = ref "" in
+
+ (* parse argv *)
+ let larg = [
+ ("-i", Arg.Set_string input, "input file");
+ ("-o", Arg.Set_string output, "output file");
+ ] in
+ let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
+ Arg.parse larg (fun s -> ()) usage_msg;
+
+ if !output = "" then output := default_output_filename !input;
+
+ match !input with
+ | "" -> Printf.printf "%s\n" usage_msg
+ | file -> Codegen.generate (parse_file file) !output !input
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Lexing
+open Syntax
+open Parser
+
+let comment_depth = ref 0
+let comment_start = ref dummy_pos
+
+let line_num = ref 0
+
+let init lexbuf fname =
+ lexbuf.lex_curr_p <- { pos_fname = fname;
+ pos_lnum = 1;
+ pos_bol = 0;
+ pos_cnum = 0 }
+
+let raise_syntax_error e loc =
+ raise (Syntax_error (e, loc))
+
+}
+
+let letter = ['A'-'Z' 'a'-'z']
+
+(* The handling of '.' is a bit of a hack for now; not sure if it's
+ really needed. *)
+let ident_first = letter | '_'
+let ident_others = letter | ['0'-'9'] | '_' | '\'' | '.'
+let ident = ident_first ident_others*
+
+rule main = parse
+| [' ' '\009' '\012' '\r']+ { main lexbuf }
+
+| ['\n'] { new_line lexbuf; main lexbuf}
+
+| "*)" { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
+
+| "(*" { comment_depth := 1; comment_start := lexeme_start_p lexbuf;
+ comment lexbuf; main lexbuf }
+
+| eof { EOF }
+| "=" { EQUAL }
+| "*" { STAR }
+| ";" { SEMI }
+| ";;" { SEMISEMI }
+| ":" { COLON }
+| "|" { BAR }
+
+| "{" { LBRACE }
+| "}" { RBRACE }
+| "(" { LPAREN }
+| ")" { RPAREN }
+| "[" { LBRACK }
+| "]" { RBRACK }
+
+| "type" { TYPE }
+| "and" { AND }
+| "mutable" { MUTABLE }
+| "of" { OF }
+
+(* general identifiers. we could handle the '.' here. *)
+| ident
+ { let str = lexeme lexbuf in
+ match String.get str 0 with
+ | 'A' .. 'Z' -> UIDENT str
+ | 'a' .. 'z' -> LIDENT str
+ | _ -> raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
+ }
+| _ { raise_syntax_error (Illegal_character (lexeme_char lexbuf 0)) (lexeme_start_p lexbuf) }
+
+
+and comment = parse
+| "(*" { incr comment_depth; comment lexbuf }
+| "*)" { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
+| ['\n'] { new_line lexbuf; comment lexbuf }
+| eof { raise_syntax_error Unterminated_comment !comment_start }
+| _ { comment lexbuf }
--- /dev/null
+/*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Syntax
+
+let raise_syntax_error e pos =
+ raise (Syntax_error (e, pos))
+
+%}
+
+/* keywords */
+%token TYPE AND MUTABLE OF
+
+%token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK
+%token EQUAL STAR SEMI SEMISEMI COLON BAR
+%token EOF
+
+%token <string> UIDENT LIDENT
+
+%start defn_list
+
+%type <Syntax.type_defn list> defn_list
+
+%%
+
+defn_list:
+| defns EOF { List.rev $1 }
+;
+
+defns:
+| defns top_defn_term { $2 :: $1 }
+| /* epsilon */ { [] }
+;
+
+top_defn_term:
+| defn semi { $1 }
+
+defn:
+| TYPE eqn { [ $2 ] }
+
+| TYPE eqn AND defn_parts { $2 :: (List.rev $4) }
+
+defn_parts:
+| defn_parts AND eqn { $3 :: $1 }
+| eqn { [ $1 ] }
+
+eqn:
+| LIDENT EQUAL repn { ($1, $3) }
+;
+
+semi:
+| SEMISEMI {}
+| /* epsilon */ {}
+
+repn:
+| expr_or_tuple { $1 }
+| record { C_record (List.rev $1) }
+| variant { C_variant (List.rev $1) }
+
+expr_or_tuple:
+| expr { $1 }
+| expr STAR tuple { C_tuple ($1 :: (List.rev $3)) }
+
+tuple:
+| tuple STAR expr { $3 :: $1 }
+| expr { [ $1 ] }
+
+expr:
+| LPAREN expr_or_tuple RPAREN { $2 }
+
+| expr LIDENT
+ { match $2 with
+ | "option" -> C_option $1
+ | "list" -> C_list $1
+ | "array" -> C_array $1
+ | s -> (raise_syntax_error
+ (Unsupported_type_constructor s)
+ (Parsing.rhs_start_pos 2))
+ }
+| base { C_base $1 }
+
+base:
+| LIDENT { match $1 with
+ | "string" -> B_string
+ | "int" -> B_int
+ | "int64" -> B_int64
+ | "bool" -> B_bool
+ | s -> B_ident s
+ }
+/* TODO:
+| UIDENT { raise_syntax_error (Invalid_ident $1) }
+*/
+
+record:
+| LBRACE field_decls opt_semi RBRACE { $2 }
+
+field_decls:
+| field_decls SEMI field_decl { $3 :: $1 }
+| field_decl { [ $1 ] }
+
+opt_semi:
+| SEMI {}
+| /* epsilon */ {}
+
+field_decl:
+| LIDENT COLON expr_or_tuple { ($1, $3) }
+| MUTABLE LIDENT COLON expr_or_tuple { ($2, $4) }
+
+variant:
+| variant BAR constr { $3 :: $1 }
+| constr { [ $1 ] }
+| /* epsilon */ { [] }
+
+constr:
+| UIDENT { CD_tuple ($1, []) }
+| UIDENT OF expr { CD_tuple ($1, [ $3 ]) }
+
+| UIDENT OF expr STAR tuple { CD_tuple ($1, ($3 :: (List.rev $5))) }
+
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 syntax_error =
+ | Illegal_character of char
+ | Invalid_ident of string
+ | Unsupported_type_constructor of string
+ | Unmatched_comment
+ | Unterminated_comment
+
+exception Syntax_error of syntax_error * Lexing.position
+
+type base_type =
+ | B_string
+ | B_int
+ | B_int64
+ | B_bool
+ | B_ident of string
+
+type complex_type =
+ | C_base of base_type
+ | C_option of complex_type
+ | C_list of complex_type
+ | C_array of complex_type
+ | C_tuple of complex_type list
+ | C_record of (string * complex_type) list
+ | C_variant of constr_decl list
+
+and constr_decl =
+ | CD_tuple of string * complex_type list
+
+type type_defn = (string * complex_type) list
+
--- /dev/null
+.PHONY: clean
+
+OCAMLFLAGS += -I .. -I ../..
+
+test_types_json_conv.ml: test_types.ml $(JSON_CONV)
+ ../$(JSON_CONV_PROG) -i $< -o $@
+
+TESTER_FILES[] =
+ test_types
+ test_types_json_conv
+ test_json_conv
+
+OCAML_LIBS[] +=
+ ../../json
+
+TESTER_PROG = test_json_conv
+TESTER = $(OCamlProgram $(TESTER_PROG), $(TESTER_FILES))
+
+.DEFAULT: $(TESTER)
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
+
--- /dev/null
+open Test_types
+open Test_types_json_conv
+
+let do_print = ref false
+
+let test_list to_j of_j o_list =
+ List.iter (fun t ->
+ let j = to_j t in
+ let o = of_j j in
+ if !do_print then
+ Printf.printf "testing of_j(to_j(.) == . for %s\n" (Json.json_to_string j);
+ assert (o = t)
+ ) o_list;
+ let j_list = List.map to_j o_list in
+ List.iter (fun t ->
+ let o = of_j t in
+ let j = to_j o in
+ if !do_print then
+ Printf.printf "testing to_j(of_j(.) == . for %s\n" (Json.json_to_string j);
+ assert (j = t)
+ ) j_list
+
+
+let check_base_type () =
+ let bs = [ B_int 3;
+ B_int64 1L;
+ B_bool false;
+ B_string "test"
+ ] in
+ test_list base_type_to_json base_type_of_json bs
+
+let check_simple_type () =
+ let ss = [ S_int_option None;
+ S_int_option (Some 2);
+ S_int64_option (Some 0L);
+ S_bool_option (Some true);
+ S_string_option (Some "tset");
+
+ S_int_list [ ];
+ S_int_list [ 3; 2; -1 ];
+ S_bool_list [ true; false; false; true; false ];
+ S_int64_list [ 1L; -3L; 2L; 5L];
+ S_string_list [ "iggy"; "franti"; "zappa" ];
+
+ S_int_array [| |];
+ S_int_array [| 1; 3; 2 |];
+ S_bool_array [| false; true; false; false; true |];
+ S_int64_array [| 1L; 3L; -2L; 5L |];
+ S_string_array [| "iggy"; "franti"; "zappa" |]
+ ] in
+ test_list simple_type_to_json simple_type_of_json ss
+
+let check_record_type () =
+ let rs = [ { int = 32;
+ int64 = 32L;
+ bool = false;
+ string = "record";
+
+ int_list = [ 0; 1; 2; -6; 4; 5];
+ int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ bool_array = [| false; true; false; false; true |];
+
+ prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ } ] in
+ test_list record_type_to_json record_type_of_json rs
+
+let check_complex_type1 () =
+ let cs = [ [| |];
+ [| ([], true) |];
+ [| ([4; 3; 1], false); ([1; 3; 4], true) |];
+ ] in
+ test_list complex_type1_to_json complex_type1_of_json cs
+
+let check_complex_type2 () =
+ let cs = [ { record = { int = 32;
+ int64 = 32L;
+ bool = false;
+ string = "record";
+
+ int_list = [ 0; 1; 2; -6; 4; 5];
+ int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ bool_array = [| false; true; false; false; true |];
+
+ prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ };
+ complex_type1 = [| ([4; 3; 1], false); ([1; 3; 4], true) |];
+ }
+ ] in
+ test_list complex_type2_to_json complex_type2_of_json cs
+
+let parse_args () =
+ let options = [("-print-value", Arg.Set do_print, " print output")] in
+ let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
+ Arg.parse (Arg.align options) (fun f -> ()) usage
+
+let _ =
+ parse_args ();
+ check_base_type ();
+ check_simple_type ();
+ check_record_type ();
+ check_complex_type1 ();
+ check_complex_type2 ()
+
--- /dev/null
+
+type base_type =
+ | B_int of int
+ | B_int64 of int64
+ | B_bool of bool
+ | B_string of string
+
+type simple_type =
+ | S_int_option of int option
+ | S_int64_option of int64 option
+ | S_bool_option of bool option
+ | S_string_option of string option
+
+ | S_int_list of int list
+ | S_bool_list of bool list
+ | S_int64_list of int64 list
+ | S_string_list of string list
+
+ | S_int_array of int array
+ | S_bool_array of bool array
+ | S_int64_array of int64 array
+ | S_string_array of string array
+
+type record_type =
+{
+ int: int;
+ int64: int64;
+ bool: bool;
+ string: string;
+
+ int_list: int list;
+ int64_option_array: (int64 option) array;
+ bool_array: bool array;
+
+ prod_list: ((int * bool) list) * string;
+}
+
+
+type complex_type1 = ((int list) * bool) array
+
+type complex_type2 =
+{
+ record: record_type;
+ complex_type1: complex_type1;
+}
--- /dev/null
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I $(TOPLEVEL)/libs/json
+
+#GEN_JSON_CONV = $(TOPLEVEL)/libs/json/gen_json_conv/gen_json_conv
+#syntax_json_conv.ml: syntax.ml $(GEN_JSON_CONV)
+# $(GEN_JSON_CONV) -i $< -o $@
+
+#GENERATED_FILES = syntax_json_conv.ml
+
+gen_rpc_OBJS = syntax syntax_json_conv rpc_decl codegen gen_rpc
+gen_rpc_LIBS = unix.cmxa $(TOPLEVEL)/libs/json/json.cmxa
+
+ALL_OCAML_OBJS = $(gen_rpc_OBJS)
+
+OCAML_PROGRAM = gen_rpc
+PROGRAMS = $(OCAML_PROGRAM)
+
+all: $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+include $(TOPLEVEL)/Makefile.rules
+
--- /dev/null
+.PHONY: clean
+
+syntax_json_conv.ml: syntax.ml $(JSON_CONV)
+ ../gen_json_conv/$(JSON_CONV_PROG) -i $< -o $@
+
+OCAMLFLAGS += -I ..
+
+GEN_RPC_FILES[] =
+ syntax
+ syntax_json_conv
+ rpc_decl
+ codegen
+ gen_rpc
+
+OCAML_LIBS += ../json
+
+GEN_RPC_PROG = gen_rpc
+GEN_RPC = $(OCamlProgram $(GEN_RPC_PROG), $(GEN_RPC_FILES))
+
+.DEFAULT: $(GEN_RPC)
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
+
+.SUBDIRS: tests
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Syntax
+open Rpc_decl
+open Format
+
+type var = { stem: string; mark: int }
+
+let name_of_var v =
+ match v.mark with
+ | 0 -> Printf.sprintf "%s" v.stem
+ | d -> Printf.sprintf "%s_%d" v.stem d
+
+module Var_env = struct
+ module StringMap = Map.Make (struct type t = string let compare = compare end)
+
+ type name_entry = { cur_mark: int; entries: var list; }
+
+ let new_name_entry = { cur_mark = 0; entries = [] }
+
+ let make_new_var name_entry name =
+ let var = { stem = name; mark = name_entry.cur_mark} in
+ var, { cur_mark = var.mark + 1; entries = var :: name_entry.entries }
+
+ type t = name_entry StringMap.t
+ let new_env = StringMap.empty
+
+ let new_var env full_name =
+ let var, new_entry = make_new_var (try StringMap.find full_name env
+ with Not_found -> new_name_entry) full_name in
+ var, (StringMap.add full_name new_entry env)
+
+ let new_ident_from_name env ?(prefix="") ?(suffix="") stem =
+ new_var env (prefix ^ stem ^ suffix)
+
+ let new_idents_from_names env ?(prefix="") ?(suffix="") names =
+ let vlist, env =
+ List.fold_left (fun (vlist, env) n ->
+ let v, env' = new_ident_from_name env ~prefix ~suffix n in
+ (v :: vlist), env'
+ ) ([], env) names in
+ (List.rev vlist), env
+end
+
+
+module Server = struct
+ let start_server ff s =
+ fprintf ff "module %s =@\n" (String.capitalize s.server_name);
+ fprintf ff "@[<v 8>struct@,"
+
+ let end_server ff =
+ fprintf ff "@]@\nend@\n@\n@?"
+
+ let gen_dispatch_struct ff server rpc_list notif_list =
+ let sig_name = (String.lowercase server.server_name) ^ "_impl" in
+ fprintf ff "type %s =@\n" sig_name;
+ fprintf ff "@[<v 8>{@,";
+ fprintf ff "(* RPCs *)";
+ List.iter (fun (rpc, resp) ->
+ let sg = List.map (fun p -> p.param_type) rpc.rpc_request.request_params in
+ let sg = sg @ [ resp.response_value.param_type ] in
+ fprintf ff "@,%s: %s;" rpc.rpc_request.request_handler (String.concat " -> " sg)
+ ) rpc_list;
+ fprintf ff "@,@,(* Notifications *)";
+ List.iter (fun n ->
+ let sg = List.map (fun p -> p.param_type) n.rpc_request.request_params in
+ let sg = sg @ [ "unit" ] in
+ fprintf ff "@,%s: %s;" n.rpc_request.request_handler (String.concat " -> " sg)
+ ) notif_list;
+ fprintf ff "@,@,(* Exception error handler *)";
+ fprintf ff "@,%s: exn -> Json_rpc.rpc_error" server.server_error_handler;
+ fprintf ff "@]@\n}@\n@\n";
+ sig_name
+
+ let gen_param ff venv arrvn i p =
+ let arg, venv = Var_env.new_ident_from_name venv p.param_name in
+ fprintf ff "let %s = %s_of_json %s.(%d) in@," (name_of_var arg) p.param_type arrvn i;
+ arg, venv
+
+ let gen_request ff venv reqv impl_module rpc resp =
+ let arrv, venv = Var_env.new_ident_from_name venv "params" in
+ let arrvn, reqvn = name_of_var arrv, name_of_var reqv in
+ let methname = rpc.rpc_request.request_handler in
+ let params = rpc.rpc_request.request_params in
+ fprintf ff "@[<v 8>| \"%s\" ->@," rpc.rpc_request.request_name;
+ fprintf ff "let %s = Json_conv.get_array %s.Json_rpc.params in@," arrvn reqvn;
+ fprintf ff "Json_conv.check_array_with_length %s %d;@," arrvn (List.length params);
+ let paramsv, venv, _ =
+ List.fold_left (fun (alist, venv, i) p ->
+ let a, venv = gen_param ff venv arrvn i p in
+ (a :: alist), venv, (i + 1)
+ ) ([], venv, 0) params in
+ let respv, venv = Var_env.new_ident_from_name venv "resp" in
+ let respjv, venv = Var_env.new_ident_from_name venv "resp_j" in
+ let respvn, respjvn = name_of_var respv, name_of_var respjv in
+ let args_str = String.concat " " (List.map (fun v -> name_of_var v) (List.rev paramsv)) in
+ fprintf ff "let %s = %s.%s %s in@," respvn impl_module methname args_str;
+ fprintf ff "let %s = %s_to_json %s in@," respjvn resp.response_value.param_type respvn;
+ fprintf ff "Json_rpc.Result { Json_rpc.result = %s }@]@," respjvn
+
+ let gen_notification ff venv reqv impl_module rpc =
+ let arrv, venv = Var_env.new_ident_from_name venv "params" in
+ let arrvn, reqvn = name_of_var arrv, name_of_var reqv in
+ let methname = rpc.rpc_request.request_handler in
+ let params = rpc.rpc_request.request_params in
+ fprintf ff "@[<v 8>| \"%s\" ->@," rpc.rpc_request.request_name;
+ fprintf ff "let %s = Json_conv.get_array %s.Json_rpc.params in@," arrvn reqvn;
+ fprintf ff "Json_conv.check_array_with_length %s %d;@," arrvn (List.length params);
+ let paramsv, venv, _ =
+ List.fold_left (fun (alist, venv, i) p ->
+ let a, venv = gen_param ff venv arrvn i p in
+ (a :: alist), venv, (i + 1)
+ ) ([], venv, 0) params in
+ let args_str = String.concat " " (List.map (fun v -> name_of_var v) (List.rev paramsv)) in
+ fprintf ff "%s.%s %s@]@," impl_module methname args_str
+
+ let gen_notification_dispatch ff venv server impl_module nlist =
+ let dispv, venv = Var_env.new_ident_from_name venv "dispatch_notification" in
+ let reqv, venv = Var_env.new_ident_from_name venv "req" in
+ let implv, venv = Var_env.new_ident_from_name venv impl_module in
+ let reqvn, implvn = name_of_var reqv, name_of_var implv in
+ fprintf ff "@[<v 8>let %s (%s : %s) %s =@," (name_of_var dispv) implvn impl_module reqvn;
+ fprintf ff "match %s.Json_rpc.method_name with@," reqvn;
+ List.iter (fun n -> gen_notification ff venv reqv implvn n) nlist;
+ fprintf ff "| _ -> raise (Json_rpc.JSONRPC_unknown_request %s.Json_rpc.method_name)@]@,@\n" reqvn
+
+ let gen_rpc_dispatch ff venv server impl_module rpcs =
+ let dispv, venv = Var_env.new_ident_from_name venv "dispatch_rpc" in
+ let reqidjv, venv = Var_env.new_ident_from_name venv "req_id_j" in
+ let reqv, venv = Var_env.new_ident_from_name venv "req" in
+ let implv, venv = Var_env.new_ident_from_name venv impl_module in
+ let pv, venv = Var_env.new_ident_from_name venv "payload" in
+ let reqidjvn, reqvn, implvn, pvn = name_of_var reqidjv, name_of_var reqv, name_of_var implv, name_of_var pv in
+ fprintf ff "@[<v 8>let %s (%s : %s) %s %s =@," (name_of_var dispv) implvn impl_module reqidjvn reqvn;
+ fprintf ff "@[<v 8>let %s =@," pvn;
+ fprintf ff "@[<v 8>(try@,";
+ fprintf ff "match %s.Json_rpc.method_name with@," reqvn;
+ List.iter (fun (rpc, resp) -> gen_request ff venv reqv implvn rpc resp) rpcs;
+ fprintf ff "| _ -> raise (Json_rpc.JSONRPC_unknown_request %s.Json_rpc.method_name)@]@," reqvn;
+ let ev, venv = Var_env.new_ident_from_name venv "e" in
+ let errv, venv = Var_env.new_ident_from_name venv "err" in
+ let evn, errvn = name_of_var ev, name_of_var errv in
+ fprintf ff "@[<v 8> with %s ->@," evn;
+ fprintf ff "let %s = %s.%s %s in@," errvn implvn server.server_error_handler evn;
+ fprintf ff "Json_rpc.Error %s)@]@]@," errvn;
+ fprintf ff "in@,";
+ fprintf ff "Json_rpc.rpc_response_to_json (%s, %s)@]@,@\n" reqidjvn pvn
+
+ let gen_dispatch ff impl_name =
+ fprintf ff "@[<v 8>let dispatch (%s : %s) req_j =@," impl_name impl_name;
+ fprintf ff "let req = Json_rpc.rpc_request_of_json req_j in@,";
+ fprintf ff "match req.Json_rpc.request_id with@,";
+ fprintf ff "| None -> ignore (dispatch_notification %s req); None@," impl_name;
+ fprintf ff "| Some id -> Some (dispatch_rpc %s id req)@]@,@\n" impl_name
+end
+
+module Client = struct
+ let start_maker ff s =
+ let rpcid_maker = "Rpc_id_maker" in
+ fprintf ff "module Make_%s_client (%s : Json_rpc.Rpc_id_generator) =@\n" (String.lowercase s.server_name) rpcid_maker ;
+ fprintf ff "@[<v 8>struct";
+ rpcid_maker
+
+ let end_maker ff =
+ fprintf ff "@]@\nend@\n@\n@?"
+
+ let generate_rpc ff venv rpcid_maker s rpc =
+ let params = rpc.rpc_request.request_params in
+ let args = List.map (fun p -> p.param_name) params in
+ let avlist, venv = Var_env.new_idents_from_names venv ~prefix:"o_" args in
+ let vvlist, venv = Var_env.new_idents_from_names venv ~prefix:"j_" args in
+ fprintf ff "@,@[<v 8>let jrpc_%s %s =@," rpc.rpc_request.request_name (String.concat " " (List.map name_of_var avlist));
+ List.iter2 (fun p (a, v) ->
+ fprintf ff "let %s = %s_to_json %s in@," (name_of_var v) p.param_type (name_of_var a)
+ ) params (List.combine avlist vvlist);
+ let rpcv, venv = Var_env.new_ident_from_name venv "rpc_id" in
+ let rpcvn = name_of_var rpcv in
+ let args_str = String.concat "; " (List.map name_of_var vvlist) in
+ (match rpc.rpc_response with
+ | None -> fprintf ff "let %s = None in@," rpcvn
+ | Some _ -> fprintf ff "let %s = Some (%s.get_rpc_request_id ()) in@," rpcvn rpcid_maker);
+ fprintf ff "@[<v 2>{ Json_rpc.request_id = %s;@," rpcvn;
+ fprintf ff "Json_rpc.method_name = \"%s\";@," rpc.rpc_request.request_name;
+ fprintf ff "Json_rpc.params = Json.Json_array (Array.of_list [ %s ])" args_str;
+ fprintf ff "@]@,}@]"
+end
+
+let generate_header ff =
+ let call = String.concat " " (Array.to_list Sys.argv) in
+ fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call
+
+let generate_opens ff spec =
+ List.iter (fun m -> fprintf ff "open %s@\n" (String.capitalize m)) (get_uses spec);
+ fprintf ff "@\n"
+
+let open_output fn =
+ let op_flags = [ Open_wronly ; Open_creat; Open_trunc; Open_text ] in
+ let oc = open_out_gen op_flags 0o444 fn in
+ let ff = formatter_of_out_channel oc in
+ oc, ff
+
+let generate_server spec fn =
+ let oc, ff = open_output fn in
+ generate_header ff;
+ generate_opens ff spec;
+ List.iter (fun s ->
+ Server.start_server ff s;
+ let rpc_list, notif_list = get_sorted_rpcs_by_server spec s in
+ let sig_name = Server.gen_dispatch_struct ff s rpc_list notif_list in
+ Server.gen_rpc_dispatch ff Var_env.new_env s sig_name rpc_list;
+ Server.gen_notification_dispatch ff Var_env.new_env s sig_name notif_list;
+ Server.gen_dispatch ff sig_name;
+ Server.end_server ff;
+ fprintf ff "@\n@?"
+ ) (get_servers spec);
+ close_out oc
+
+let generate_client spec fn =
+ let oc, ff = open_output fn in
+ generate_header ff;
+ generate_opens ff spec;
+ List.iter (fun s ->
+ let rpc_list = get_rpcs_by_server spec s in
+ let rpcid_maker = Client.start_maker ff s in
+ List.iter (Client.generate_rpc ff Var_env.new_env rpcid_maker s) rpc_list;
+ Client.end_maker ff
+ ) (get_servers spec);
+ close_out oc
+
+let generate spec cfn sfn =
+ generate_client spec cfn;
+ generate_server spec sfn
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Json_parse
+open Json_conv
+open Syntax_json_conv
+
+let make_default_output_filename f suffix =
+ let dir, base = Filename.dirname f, Filename.basename f in
+ let stem = Filename.chop_extension base in
+ Filename.concat dir (stem ^ suffix)
+
+let parse_args () =
+ let input = ref "" in
+ let client = ref "" in
+ let server = ref "" in
+ let options = [ ("-i", Arg.Set_string input, " input file");
+ ("-c", Arg.Set_string client, " client interface");
+ ("-s", Arg.Set_string server, " server interface")
+ ] in
+ let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
+ let errmsg s = Printf.eprintf "%s\n" s; Arg.usage (Arg.align options) usage; exit 1 in
+ Arg.parse (Arg.align options) (fun s -> input := s) usage;
+ if !input = "" then errmsg "Unspecified input file!";
+ if !client = "" then client := make_default_output_filename !input "_client.ml";
+ if !server = "" then server := make_default_output_filename !input "_server.ml";
+ !input, !client, !server
+
+let read_whole_file ic =
+ let buf = Buffer.create 2048 in
+ let str = String.create 1024 in
+ let rec do_read () =
+ (* Don't use input_line, since it does not preserve newlines. *)
+ let read = input ic str 0 (String.length str) in
+ match read with
+ | 0 -> raise End_of_file
+ | _ -> Buffer.add_substring buf str 0 read; do_read ()
+ in
+ try do_read () with End_of_file -> Buffer.contents buf
+
+let parse_file f =
+ let rpc_decls = ref [] in
+ let count = ref 1 in
+ let ic = open_in f in
+ let input = ref (read_whole_file ic) in
+ let state = ref (init_parse_state ()) in
+ while String.length !input > 0 do
+ match parse !state !input with
+ | Json_value (v, rem) ->
+ rpc_decls := (!count, v) :: !rpc_decls;
+ incr count;
+ input := rem;
+ state := init_parse_state ()
+ | Json_parse_incomplete st ->
+ input := "";
+ state := st
+ done;
+ (match finish_parse !state with
+ | Some v -> rpc_decls := (!count, v) :: !rpc_decls;
+ | None -> ());
+ List.rev !rpc_decls
+
+
+exception Unknown_rpc_decl of int * Json.t
+exception Invalid_rpc_decl of int * (* type *) string * (* msg *) string
+
+let get_conv_err_msg err =
+ match err with
+ | Unexpected_json_type (r, e) ->
+ Printf.sprintf "type %s received when %s was expected" r e
+ | Array_length (r, e) ->
+ Printf.sprintf "array length %d received when %d was expected" r e
+ | Unknown_constructor (t, c) ->
+ Printf.sprintf "unknown constructor %s received for type %s" c t
+ | Missing_object_field f ->
+ Printf.sprintf "missing object field %s" f
+
+let print_exception e =
+ let msg =
+ match e with
+ | Unexpected_char (l, c, state) ->
+ Printf.sprintf "Line %d: Unexpected char %C (x%X) encountered in state %s"
+ l c (Char.code c) state
+ | Invalid_value (l, v, t) ->
+ Printf.sprintf "Line %d: '%s' is an invalid %s" l v t
+ | Invalid_leading_zero (l, s) ->
+ Printf.sprintf "Line %d: '%s' should not have leading zeros" l s
+ | Unterminated_value (l, s) ->
+ Printf.sprintf "Line %d: unterminated %s" l s
+ | Internal_error (l, m) ->
+ Printf.sprintf "Line %d: Internal error: %s" l m
+ | Json_conv_failure err ->
+ Printf.sprintf "Conversion error: %s" (get_conv_err_msg err)
+ | Unknown_rpc_decl (i, j) ->
+ Printf.sprintf "Rpc declaration #%d is of unknown type." i
+ | Invalid_rpc_decl (i, n, m) ->
+ Printf.sprintf "Error parsing decl %d for %s: %s" i n m
+ | Sys_error s ->
+ Printf.sprintf "%s" s
+ | e ->
+ Printf.sprintf "%s" (Printexc.to_string e)
+ in
+ Printf.eprintf "%s\n" msg
+
+let process_jdecl (i, j) =
+ if not (Json.is_object j) then
+ raise (Unknown_rpc_decl (i, j));
+ let obj = get_object_table j in
+ if (is_object_field_present obj "use_modules") then
+ try Rpc_decl.Rpc_use (use_of_json j)
+ with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "use", (get_conv_err_msg err)))
+ else if (is_object_field_present obj "server_name") then
+ try Rpc_decl.Rpc_server (server_of_json j)
+ with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "server", (get_conv_err_msg err)))
+ else if (is_object_field_present obj "rpc_type") then
+ try Rpc_decl.Rpc_rpc (rpc_of_json j)
+ with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "rpc", (get_conv_err_msg err)))
+ else
+ raise (Unknown_rpc_decl (i, j))
+
+let _ =
+ let input, client, server = parse_args () in
+ try
+ let jdecls = parse_file input in
+ Printf.printf "%d decls parsed.\n" (List.length jdecls);
+ let decls = List.map process_jdecl jdecls in
+ let spec = Rpc_decl.spec_with_decls decls in
+ Codegen.generate spec client server;
+ exit 0
+ with e ->
+ print_exception e;
+ exit 1
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 Syntax
+
+type decl =
+ | Rpc_use of use
+ | Rpc_server of server
+ | Rpc_rpc of rpc
+
+type elem = Server | RPC
+
+let elem_name = function Server -> "server" | RPC -> "rpc"
+
+type spec =
+{
+ uses: string list;
+ servers: server list;
+ rpcs: rpc list;
+}
+
+let init_spec =
+{
+ uses = [];
+ servers = [];
+ rpcs = []
+}
+
+let get_rpcs_by_server spec server =
+ List.rev (List.filter (fun r -> r.rpc_server = server.server_name) spec.rpcs)
+
+let get_sorted_rpcs_by_server spec server =
+ let rpcs = List.filter (fun r -> r.rpc_server = server.server_name) spec.rpcs in
+ let rlist, nlist =
+ List.fold_left (fun (rlist, nlist) rpc ->
+ match rpc.rpc_response with
+ | None -> rlist, rpc :: nlist
+ | Some r -> (rpc, r) :: rlist, nlist
+ ) ([], []) rpcs
+ in rlist, nlist
+
+exception Multiple_decl of elem * string
+exception Unknown_ref of elem * string
+exception Unknown_RPC_type of string
+exception Notification_has_response of string
+exception RPC_needs_response of string
+
+let present spec elem name =
+ try
+ match elem with
+ | Server -> ignore (List.find (fun s -> s.server_name = name) spec.servers); true
+ | RPC -> ignore (List.find (fun r -> (r.rpc_server ^ "." ^ r.rpc_request.request_name) = name) spec.rpcs); true
+ with Not_found -> false
+
+let check_new spec elem name =
+ if present spec elem name then raise (Multiple_decl (elem, name))
+
+let check_existing spec elem name =
+ if not (present spec elem name) then raise (Unknown_ref (elem, name))
+
+let add_use spec u =
+ List.fold_left (fun spec m ->
+ if not (List.mem m spec.uses)
+ then { spec with uses = m :: spec.uses }
+ else spec
+ ) spec u.use_modules
+
+let get_uses spec = List.rev spec.uses
+
+let add_server spec s =
+ check_new spec Server s.server_name;
+ { spec with servers = s :: spec.servers }
+
+let get_servers spec = List.rev spec.servers
+
+let add_rpc spec r =
+ let name = r.rpc_request.request_name in
+ check_new spec RPC (r.rpc_server ^ "." ^ name);
+ check_existing spec Server r.rpc_server;
+ (match r.rpc_type with
+ | "notification" | "Notification" ->
+ if r.rpc_response <> None then
+ raise (Notification_has_response name)
+ | "rpc" | "RPC" ->
+ if r.rpc_response = None then
+ raise (RPC_needs_response name)
+ | s -> raise (Unknown_RPC_type s));
+ { spec with rpcs = r :: spec.rpcs }
+
+let add_decl spec = function
+ | Rpc_use u -> add_use spec u
+ | Rpc_server s -> add_server spec s
+ | Rpc_rpc r -> add_rpc spec r
+
+let error_message e =
+ match e with
+ | Multiple_decl (e, n) ->
+ Printf.sprintf "Repeated declaration of %s \"%s\"" (elem_name e) n
+ | Unknown_ref (e, n) ->
+ Printf.sprintf "Reference to unknown %s \"%s\"" (elem_name e) n
+ | Notification_has_response n ->
+ Printf.sprintf "Notification \"%s\" cannot specify a response" n
+ | RPC_needs_response n ->
+ Printf.sprintf "RPC \"%s\" needs a response specification" n
+ | e -> raise e
+
+let spec_with_decls decls =
+ try
+ List.fold_left (fun spec d -> add_decl spec d) init_spec decls
+ with e ->
+ Printf.eprintf "%s\n" (error_message e);
+ exit 1
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * 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 use =
+{
+ use_modules: string list;
+}
+
+type server =
+{
+ server_name: string;
+ server_doc: string;
+ server_error_handler: string;
+}
+
+type param =
+{
+ param_name: string;
+ param_doc: string;
+ param_type: string;
+}
+
+type request =
+{
+ request_name: string;
+ request_doc: string;
+ request_handler: string;
+ request_params: param list;
+}
+
+type response =
+{
+ response_doc: string;
+ response_handler: string;
+ response_value: param;
+}
+
+type rpc =
+{
+ rpc_type: string;
+ rpc_server: string;
+ rpc_doc: string;
+ rpc_version: string;
+
+ rpc_deprecated: string option;
+ rpc_label_arguments: bool option;
+
+ rpc_request: request;
+ rpc_response: response option;
+}
+
--- /dev/null
+(* This file has been auto-generated using "/home/prashanth/xenclient/build/repo/xenclient-toolstack/libs/json/gen_json_conv/gen_json_conv -i syntax.ml -o syntax_json_conv.ml". *)
+
+open Json_conv
+open Syntax
+
+let rec use_to_json o =
+ (match o with
+ | { use_modules = lst } ->
+ let j_lst =
+ let lst_jlist = List.map
+ (fun str ->
+ string_to_json str
+ ) lst in
+ Json.Array (Array.of_list lst_jlist) in
+ Json.Object [| ("use_modules", j_lst) |]
+ )
+
+let rec use_of_json j =
+ let j_ftable = get_object_table j in
+ let use_modules_f = get_object_field j_ftable "use_modules" in
+ let lst =
+ let use_modules_f_oarray = Array.map
+ (fun str ->
+ string_of_json str
+ ) (get_array use_modules_f) in
+ Array.to_list use_modules_f_oarray in
+ { use_modules = lst }
+
+let rec server_to_json o =
+ (match o with
+ | { server_name = str; server_doc = str_1; server_error_handler = str_2 } ->
+ let j_str =
+ string_to_json str in
+ let j_str_1 =
+ string_to_json str_1 in
+ let j_str_2 =
+ string_to_json str_2 in
+ Json.Object [| ("server_name", j_str); ("server_doc", j_str_1); ("server_error_handler", j_str_2) |]
+ )
+
+let rec server_of_json j =
+ let j_ftable = get_object_table j in
+ let server_name_f = get_object_field j_ftable "server_name" in
+ let str =
+ string_of_json server_name_f in
+ let server_doc_f = get_object_field j_ftable "server_doc" in
+ let str_1 =
+ string_of_json server_doc_f in
+ let server_error_handler_f = get_object_field j_ftable "server_error_handler" in
+ let str_2 =
+ string_of_json server_error_handler_f in
+ { server_name = str; server_doc = str_1; server_error_handler = str_2 }
+
+let rec param_to_json o =
+ (match o with
+ | { param_name = str; param_doc = str_1; param_type = str_2 } ->
+ let j_str =
+ string_to_json str in
+ let j_str_1 =
+ string_to_json str_1 in
+ let j_str_2 =
+ string_to_json str_2 in
+ Json.Object [| ("param_name", j_str); ("param_doc", j_str_1); ("param_type", j_str_2) |]
+ )
+
+let rec param_of_json j =
+ let j_ftable = get_object_table j in
+ let param_name_f = get_object_field j_ftable "param_name" in
+ let str =
+ string_of_json param_name_f in
+ let param_doc_f = get_object_field j_ftable "param_doc" in
+ let str_1 =
+ string_of_json param_doc_f in
+ let param_type_f = get_object_field j_ftable "param_type" in
+ let str_2 =
+ string_of_json param_type_f in
+ { param_name = str; param_doc = str_1; param_type = str_2 }
+
+let rec request_to_json o =
+ (match o with
+ | { request_name = str; request_doc = str_1; request_handler = str_2; request_params = lst } ->
+ let j_str =
+ string_to_json str in
+ let j_str_1 =
+ string_to_json str_1 in
+ let j_str_2 =
+ string_to_json str_2 in
+ let j_lst =
+ let lst_jlist = List.map
+ (fun param ->
+ param_to_json param
+ ) lst in
+ Json.Array (Array.of_list lst_jlist) in
+ Json.Object [| ("request_name", j_str); ("request_doc", j_str_1); ("request_handler", j_str_2); ("request_params", j_lst) |]
+ )
+
+let rec request_of_json j =
+ let j_ftable = get_object_table j in
+ let request_name_f = get_object_field j_ftable "request_name" in
+ let str =
+ string_of_json request_name_f in
+ let request_doc_f = get_object_field j_ftable "request_doc" in
+ let str_1 =
+ string_of_json request_doc_f in
+ let request_handler_f = get_object_field j_ftable "request_handler" in
+ let str_2 =
+ string_of_json request_handler_f in
+ let request_params_f = get_object_field j_ftable "request_params" in
+ let lst =
+ let request_params_f_oarray = Array.map
+ (fun param ->
+ param_of_json param
+ ) (get_array request_params_f) in
+ Array.to_list request_params_f_oarray in
+ { request_name = str; request_doc = str_1; request_handler = str_2; request_params = lst }
+
+let rec response_to_json o =
+ (match o with
+ | { response_doc = str; response_handler = str_1; response_value = param } ->
+ let j_str =
+ string_to_json str in
+ let j_str_1 =
+ string_to_json str_1 in
+ let j_param =
+ param_to_json param in
+ Json.Object [| ("response_doc", j_str); ("response_handler", j_str_1); ("response_value", j_param) |]
+ )
+
+let rec response_of_json j =
+ let j_ftable = get_object_table j in
+ let response_doc_f = get_object_field j_ftable "response_doc" in
+ let str =
+ string_of_json response_doc_f in
+ let response_handler_f = get_object_field j_ftable "response_handler" in
+ let str_1 =
+ string_of_json response_handler_f in
+ let response_value_f = get_object_field j_ftable "response_value" in
+ let param =
+ param_of_json response_value_f in
+ { response_doc = str; response_handler = str_1; response_value = param }
+
+let rec rpc_to_json o =
+ (match o with
+ | { rpc_type = str; rpc_server = str_1; rpc_doc = str_2; rpc_version = str_3; rpc_deprecated = opt; rpc_label_arguments = opt_1; rpc_request = request; rpc_response = opt_2 } ->
+ let j_str =
+ string_to_json str in
+ let j_str_1 =
+ string_to_json str_1 in
+ let j_str_2 =
+ string_to_json str_2 in
+ let j_str_3 =
+ string_to_json str_3 in
+ let j_opt =
+ (match opt with
+ | None -> Json.Null
+ | Some str_4 ->
+ string_to_json str_4
+ ) in
+ let j_opt_1 =
+ (match opt_1 with
+ | None -> Json.Null
+ | Some bool ->
+ bool_to_json bool
+ ) in
+ let j_request =
+ request_to_json request in
+ let j_opt_2 =
+ (match opt_2 with
+ | None -> Json.Null
+ | Some response ->
+ response_to_json response
+ ) in
+ Json.Object [| ("rpc_type", j_str); ("rpc_server", j_str_1); ("rpc_doc", j_str_2); ("rpc_version", j_str_3); ("rpc_deprecated", j_opt); ("rpc_label_arguments", j_opt_1); ("rpc_request", j_request); ("rpc_response", j_opt_2) |]
+ )
+
+let rec rpc_of_json j =
+ let j_ftable = get_object_table j in
+ let rpc_type_f = get_object_field j_ftable "rpc_type" in
+ let str =
+ string_of_json rpc_type_f in
+ let rpc_server_f = get_object_field j_ftable "rpc_server" in
+ let str_1 =
+ string_of_json rpc_server_f in
+ let rpc_doc_f = get_object_field j_ftable "rpc_doc" in
+ let str_2 =
+ string_of_json rpc_doc_f in
+ let rpc_version_f = get_object_field j_ftable "rpc_version" in
+ let str_3 =
+ string_of_json rpc_version_f in
+ let rpc_deprecated_f = get_optional_object_field j_ftable "rpc_deprecated" in
+ let opt =
+ (match rpc_deprecated_f with
+ | Json.Null -> None
+ | str_4 ->
+ Some (string_of_json str_4)
+ ) in
+ let rpc_label_arguments_f = get_optional_object_field j_ftable "rpc_label_arguments" in
+ let opt_1 =
+ (match rpc_label_arguments_f with
+ | Json.Null -> None
+ | bool ->
+ Some (bool_of_json bool)
+ ) in
+ let rpc_request_f = get_object_field j_ftable "rpc_request" in
+ let request =
+ request_of_json rpc_request_f in
+ let rpc_response_f = get_optional_object_field j_ftable "rpc_response" in
+ let opt_2 =
+ (match rpc_response_f with
+ | Json.Null -> None
+ | response ->
+ Some (response_of_json response)
+ ) in
+ { rpc_type = str; rpc_server = str_1; rpc_doc = str_2; rpc_version = str_3; rpc_deprecated = opt; rpc_label_arguments = opt_1; rpc_request = request; rpc_response = opt_2 }
+
--- /dev/null
+.PHONY: clean
+
+rpc_types_json_conv.ml: rpc_types.ml $(JSON_CONV)
+ ../../gen_json_conv/$(JSON_CONV_PROG) -i $< -o $@
+
+rpc_defns_client.ml rpc_defns_server.ml: rpc_defns.json $(GEN_RPC)
+ ../$(GEN_RPC_PROG) $<
+
+OCAMLFLAGS += -I ../..
+
+RPC_TEST_FILES[] =
+ rpc_types
+ rpc_types_json_conv
+ rpc_defns_client
+ rpc_defns_server
+ test_rpc
+
+
+OCAML_LIBS = ../../json
+
+RPC_TEST_PROG = test
+RPC_TEST = $(OCamlProgram $(RPC_TEST_PROG), $(RPC_TEST_FILES))
+
+.DEFAULT: $(RPC_TEST)
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo rpc_defns_client.ml rpc_defns_server.ml
+
--- /dev/null
+{ "use_modules": ["rpc_types", "rpc_types_json_conv"]}
+
+{ "server_name": "server",
+ "server_doc": "",
+ "server_error_handler": "server_error_handler"
+}
+
+{ "rpc_type": "rpc",
+ "rpc_server": "server",
+ "rpc_doc": "documentation",
+ "rpc_version": "string",
+
+ "rpc_request": { "request_name": "request1",
+ "request_doc": "documentation",
+ "request_handler": "request1_handler",
+ "request_params": [ { "param_name": "request1_arg1",
+ "param_doc": "documentation",
+ "param_type": "arg1_type"
+ }
+ ]
+ },
+
+ "rpc_response": { "response_doc": "documentation",
+ "response_handler": "response1_handler",
+ "response_value": { "param_name": "resp1",
+ "param_doc": "documentation",
+ "param_type": "resp1_type"
+ }
+ },
+
+ "rpc_deprecated": "string",
+ "rpc_label_arguments": false
+}
+
+{ "rpc_type": "rpc",
+ "rpc_server": "server",
+ "rpc_doc": "documentation",
+ "rpc_version": "string",
+
+ "rpc_request": { "request_name": "request2",
+ "request_doc": "documentation",
+ "request_handler": "request2_handler",
+ "request_params": [ { "param_name": "arg1",
+ "param_doc": "documentation",
+ "param_type": "arg1_type"
+ },
+ { "param_name": "arg2",
+ "param_doc": "documentation",
+ "param_type": "arg2_type"
+ },
+ { "param_name": "arg3",
+ "param_doc": "documentation",
+ "param_type": "arg3_type"
+ }
+ ]
+ },
+
+ "rpc_response": { "response_doc": "documentation",
+ "response_handler": "client_function",
+ "response_value": { "param_name": "resp2",
+ "param_doc": "documentation",
+ "param_type": "resp2_type"
+ }
+ },
+
+ "rpc_label_arguments": true
+}
+
+{ "rpc_type": "notification",
+ "rpc_server": "server",
+ "rpc_doc": "documentation",
+ "rpc_version": "string",
+
+ "rpc_request": { "request_name": "notification1",
+ "request_doc": "documentation",
+ "request_handler": "not1_handler",
+ "request_params": [ { "param_name": "arg1",
+ "param_doc": "documentation",
+ "param_type": "arg1_type"
+ },
+ { "param_name": "arg2",
+ "param_doc": "documentation",
+ "param_type": "arg2_type"
+ },
+ { "param_name": "arg3",
+ "param_doc": "documentation",
+ "param_type": "arg3_type"
+ }
+ ]
+ }
+}
+
+{ "server_name": "server1",
+ "server_doc": "",
+ "server_error_handler": "server1_error_handler"
+}
+
+{ "rpc_type": "rpc",
+ "rpc_server": "server1",
+ "rpc_doc": "documentation",
+ "rpc_version": "string",
+
+ "rpc_request": { "request_name": "request2",
+ "request_doc": "documentation",
+ "request_handler": "request2_handler",
+ "request_params": [ { "param_name": "arg1",
+ "param_doc": "documentation",
+ "param_type": "arg1_type"
+ },
+ { "param_name": "arg2",
+ "param_doc": "documentation",
+ "param_type": "arg2_type"
+ },
+ { "param_name": "arg3",
+ "param_doc": "documentation",
+ "param_type": "arg3_type"
+ }
+ ]
+ },
+
+ "rpc_response": { "response_doc": "documentation",
+ "response_handler": "client_function",
+ "response_value": { "param_name": "resp2",
+ "param_doc": "documentation",
+ "param_type": "resp2_type"
+ }
+ },
+
+ "rpc_label_arguments": true
+}
--- /dev/null
+
+type arg1_type = int
+
+type arg2_type = (string * arg1_type) list
+
+type arg3_type = bool
+
+type resp1_type = bool option
+
+type resp2_type = string
--- /dev/null
+open Rpc_types
+open Rpc_types_json_conv
+open Rpc_defns_server
+open Rpc_defns_client
+
+(* First, implement the Json-rpc id generator. *)
+module I : Json_rpc.Rpc_id_generator = struct
+ let cur_id = ref 0L
+
+ let get_rpc_request_id () =
+ let id = !cur_id in
+ cur_id := Int64.add !cur_id 1L;
+ Json.Json_int id
+end
+
+(* Now, create the client-side wrappers. *)
+
+module C = Make_server_client (I)
+
+(* Finally, implement the server-side call dispatch structure. *)
+module S = struct
+ let req1_handler arg1 =
+ if arg1 < 5 then None
+ else if arg1 < 10 then Some false
+ else Some true
+
+ let req2_handler arg1 arg2 arg3 =
+ ((string_of_int arg1)
+ ^ ".[" ^ (String.concat "," (List.map (fun (s, i) -> s ^ "-" ^ (string_of_int i)) arg2))
+ ^ "]." ^ (if arg3 then "true" else "false"))
+
+ let not1_handler arg1 arg2 arg3 =
+ assert ((arg1 = 5)
+ && (arg2 = ["5", 5; "10", 10])
+ && arg3)
+
+ let error_handler e =
+ { Json_rpc.code = 2;
+ Json_rpc.message = Printexc.to_string e;
+ Json_rpc.data = Some (Json.Json_string "details")
+ }
+
+ let server_impl =
+ { Server.request1_handler = req1_handler;
+ Server.request2_handler = req2_handler;
+ Server.not1_handler = not1_handler;
+ Server.server_error_handler = error_handler
+ }
+end
+
+let rpc_invoke req resp_fun =
+ (* Client-side request processing: *)
+
+ (* 1) create the corresponding json-rpc request object to send over the wire. *)
+ let jreq_c = Json_rpc.rpc_request_to_json req in
+
+ (* 2) send it over the wire. *)
+ let jnet_c = Json.json_to_string jreq_c in
+ let _ = Printf.printf "Sending request: %s\n" jnet_c in
+
+ (* Server-side processing: *)
+
+ (* i) parse the string into a json value *)
+ let ps = Json_parse.init_parse_state () in
+ let jreq_s = match Json_parse.parse ps jnet_c with
+ | Json_parse.Json_value (j, _) -> j
+ | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
+
+ (* ii) dispatch the request *)
+ let resp_j = Server.dispatch S.server_impl jreq_s in
+
+ (* iii) check whether we have a response to send back *)
+ let resp_j = match resp_j with
+ | None -> raise (Failure "unexpected notification")
+ | Some j -> j in
+
+ (* iv) send it over the wire *)
+ let jnet_s = Json.json_to_string resp_j in
+ let _ = Printf.printf "Sending response: %s\n" jnet_s in
+
+ (* Client-side response processing: *)
+
+ (* a) parse the string into a json value *)
+ let pc = Json_parse.init_parse_state () in
+ let jresp_c = match Json_parse.parse pc jnet_s with
+ | Json_parse.Json_value (j, _) -> j
+ | Json_parse.Json_parse_incomplete _ -> raise (Failure "client json parsing") in
+
+ (* b) extract the response *)
+ let resp = Json_rpc.rpc_response_of_json jresp_c in
+
+ (* c) process that response *)
+ resp_fun resp
+
+let notification_invoke testname req =
+ (* Client-side request processing: *)
+
+ (* 1) create the corresponding json-rpc request object to send over the wire. *)
+ let jreq_c = Json_rpc.rpc_request_to_json req in
+
+ (* 2) send it over the wire. *)
+ let jnet_c = Json.json_to_string jreq_c in
+ let _ = Printf.printf "Sending request: %s\n" jnet_c in
+
+ (* Server-side processing: *)
+
+ (* i) parse the string into a json value *)
+ let ps = Json_parse.init_parse_state () in
+ let jreq_s = match Json_parse.parse ps jnet_c with
+ | Json_parse.Json_value (j, _) -> j
+ | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
+
+ (* ii) dispatch the request *)
+ let resp_j = Server.dispatch S.server_impl jreq_s in
+
+ (* iii) check whether we have a response to send back *)
+ (match resp_j with
+ | None -> ()
+ | Some j -> raise (Failure (Printf.sprintf "unexpected response in test %s" testname)))
+
+
+let default_id_check req_id resp_id =
+ match req_id with
+ | None -> if not (Json.is_null resp_id) then raise (Failure "unexpected non-null resp id received")
+ | Some id -> if (id <> resp_id) then raise (Failure "resp id differs from req id")
+
+let default_error_check e =
+ raise (Failure "unexpected rpc error received.")
+
+let test_invoke req ?(id_check=default_id_check) ?(error_check=default_error_check) result_check =
+ let resp_fun (resp_id, resp) =
+ id_check req.Json_rpc.request_id resp_id;
+ match resp with
+ | Json_rpc.Result r -> result_check r
+ | Json_rpc.Error e -> error_check e
+ in
+ rpc_invoke req resp_fun
+
+let test_server () =
+ let req1_checker test_id arg1 =
+ let req = C.jrpc_request1 arg1 in
+ let exp_resp = S.req1_handler arg1 in
+ let resp_to_str r = match r with |None -> "None" | Some b -> if b then "Some true" else "Some false" in
+ let resp_checker r =
+ let got_resp = resp1_type_of_json r.Json_rpc.result in
+ if got_resp <> exp_resp
+ then raise (Failure (Printf.sprintf "req1, test %s: got \"%s\", expected \"%s\"!"
+ test_id (resp_to_str got_resp) (resp_to_str exp_resp)))
+ in
+ test_invoke req resp_checker
+ in
+ req1_checker "1" 3;
+ req1_checker "2" 7;
+ req1_checker "3" 13;
+
+ let req2_checker test_id arg1 arg2 arg3 =
+ let req = C.jrpc_request2 arg1 arg2 arg3 in
+ let exp_resp = S.req2_handler arg1 arg2 arg3 in
+ let resp_checker r =
+ let got_resp = resp2_type_of_json r.Json_rpc.result in
+ if got_resp <> exp_resp
+ then raise (Failure (Printf.sprintf "req2, test %s: got \"%s\", expected \"%s\"!" test_id got_resp exp_resp))
+ in
+ test_invoke req resp_checker
+ in
+ req2_checker "1" 1 [] true;
+ req2_checker "2" 2 [("2", 2)] true;
+ req2_checker "3" 5 [("2", 2); ("9", 6)] false;
+
+ let notif = C.jrpc_notification1 5 ["5", 5; "10", 10] true in
+ notification_invoke "not1: case 1" notif
+
+let _ =
+ test_server ()
+++ /dev/null
-TOPLEVEL=../../..
-include $(TOPLEVEL)/common.make
-
-GENERATED_FILES = lexer.ml parser.mli parser.ml
-
-gen_json_conv_OBJS = syntax lexer parser codegen gen_json_conv
-gen_json_conv_LIBS = unix.cmxa
-
-ALL_OCAML_OBJS = $(gen_json_conv_OBJS)
-
-OCAML_PROGRAM = gen_json_conv
-PROGRAMS = $(OCAML_PROGRAM)
-
-all: $(PROGRAMS)
-
-bins: $(PROGRAMS)
-
-include $(TOPLEVEL)/Makefile.rules
-
+++ /dev/null
-.PHONY: clean
-
-GEN_FILES = parser.mli parser.ml lexer.ml
-OCamlGeneratedFiles($(GEN_FILES))
-
-OCAML_OTHER_LIBS[] += unix
-CONV_FILES[] =
- lexer
- parser
- syntax
- codegen
- gen_json_conv
-
-JSON_CONV_PROG = gen_json_conv
-JSON_CONV = $(OCamlProgram $(JSON_CONV_PROG), $(CONV_FILES))
-
-.DEFAULT: $(JSON_CONV)
-
-clean:
- rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
-
-.SUBDIRS: tests
-
-export JSON_CONV_PROG JSON_CONV
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Syntax
-open Format
-
-exception Unknown_base_type of string
-
-let known_types = ((ref []) : string list ref)
-let is_known_type ident = List.mem ident !known_types
-let add_known_type ident = known_types := ident :: !known_types
-let reset_known_types () = known_types := []
-
-let base_to_str = function
- | B_string -> "string" | B_int -> "int" | B_int64 -> "int64"
- | B_bool -> "bool" | B_ident s -> s
-
-type var = { stem: string; mark: int }
-
-let name_of_var v =
- match v.mark with
- | 0 -> Printf.sprintf "%s" v.stem
- | d -> Printf.sprintf "%s_%d" v.stem d
-
-module Var_env = struct
- module StringMap = Map.Make (struct type t = string let compare = compare end)
-
- type name_entry = { cur_mark: int; entries: var list; }
-
- let new_name_entry = { cur_mark = 0; entries = [] }
-
- let make_new_var name_entry name =
- let var = { stem = name; mark = name_entry.cur_mark} in
- var, { cur_mark = var.mark + 1; entries = var :: name_entry.entries }
-
- type t = name_entry StringMap.t
- let new_env = StringMap.empty
-
- let new_var env full_name =
- let var, new_entry = make_new_var (try StringMap.find full_name env
- with Not_found -> new_name_entry) full_name in
- var, (StringMap.add full_name new_entry env)
-
- let new_ident_from_name env ?(prefix="") ?(suffix="") stem =
- new_var env (prefix ^ stem ^ suffix)
-
- let base_to_stem = function
- | B_string -> "str" | B_int -> "int" | B_int64 -> "int64"
- | B_bool -> "bool" | B_ident s -> s
-
- let complex_type_to_stem = function
- | C_base b -> base_to_stem b | C_option _ -> "opt" | C_list _ -> "lst"
- | C_array _ -> "arr" | C_tuple _ -> "tup" | C_record _ -> "rcd"
- | C_variant _ -> "var"
-
- let new_ident_from_type env ct =
- new_ident_from_name env (complex_type_to_stem ct)
-
- let new_idents_from_types env cts =
- let vlist, env =
- List.fold_left (fun (vlist, env) ct ->
- let v, env' = new_ident_from_type env ct in
- (v :: vlist), env'
- ) ([], env) cts in
- (List.rev vlist), env
-
- let new_ident_from_var env ?(prefix="") ?(suffix="") var =
- new_ident_from_name env ~prefix ~suffix var.stem
-
- let new_idents_from_vars env ?(prefix="") ?(suffix="") vlist =
- let vlist, env =
- List.fold_left (fun (vlist, env) v ->
- let v, env' = new_ident_from_var env ~prefix ~suffix v in
- (v :: vlist), env'
- ) ([], env) vlist in
- (List.rev vlist), env
-end
-
-type rec_type = First | Next
-
-module To = struct
- let prod_vars_to_str vlist =
- let elems = List.map name_of_var vlist in
- String.concat ", " elems
-
- let to_array_str ?(constr="") vlist =
- let elems = List.map name_of_var vlist in
- let constr = if constr = "" then "" else "(string_to_json \"" ^ constr ^ "\"); " in
- "[| " ^ constr ^ (String.concat "; " elems) ^ " |]"
-
- let to_object_str fn_list fv_list =
- let elems = List.map2 (fun f v ->
- Printf.sprintf "(\"%s\", %s)" f (name_of_var v)
- ) fn_list fv_list in
- "[| " ^ (String.concat "; " elems) ^ " |]"
-
- let to_record_str fnlist fvlist =
- let fields = List.map2 (fun fn fv ->
- Printf.sprintf "%s = %s" fn (name_of_var fv)
- ) fnlist fvlist in
- "{ " ^ (String.concat "; " fields) ^ " }"
-
- let rec to_json ff venv inv typ =
- let v = name_of_var inv in
- match typ with
- | C_base bt ->
- (match bt with
- | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
- | _ -> ());
- fprintf ff "%s_to_json %s" (base_to_str bt) v
- | C_option optt ->
- let optv, venv = Var_env.new_ident_from_type venv optt in
- fprintf ff "(match %s with@," v;
- fprintf ff "| None -> Json_null@,";
- fprintf ff "@[<v 8>| Some %s ->@," (name_of_var optv);
- to_json ff venv optv optt;
- fprintf ff "@]@,)"
- | C_list elemt ->
- let elemv, venv = Var_env.new_ident_from_type venv elemt in
- let jlistv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jlist" in
- let jlistvn = name_of_var jlistv in
- fprintf ff "@[<v 8>let %s = List.map@," jlistvn;
- fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- to_json ff venv elemv elemt;
- fprintf ff "@]@,) %s in@]@," v;
- fprintf ff "Json_array (Array.of_list %s)" jlistvn
- | C_array elemt ->
- let elemv, venv = Var_env.new_ident_from_type venv elemt in
- let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
- let jarrayvn = name_of_var jarrayv in
- fprintf ff "@[<v 8>let %s = Array.map@," jarrayvn;
- fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- to_json ff venv elemv elemt;
- fprintf ff "@]@,) %s in@]@," v;
- fprintf ff "Json_array %s" jarrayvn
- | C_tuple ctlist ->
- let cvlist, venv = Var_env.new_idents_from_types venv ctlist in
- let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" cvlist in
- let cvtlist = List.combine cvlist ctlist in
- fprintf ff "(match %s with@," v;
- fprintf ff "@[<v 8>| %s ->@," (prod_vars_to_str cvlist);
- List.iter2 (fun letv (cv, ct) ->
- let_bind ff venv letv cv ct
- ) letvlist cvtlist;
- fprintf ff "Json_array %s@]@,)" (to_array_str letvlist)
- | C_record cls ->
- let fnlist, ftlist = List.split cls in
- let fvlist, venv = Var_env.new_idents_from_types venv ftlist in
- let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" fvlist in
- fprintf ff "(match %s with@," v;
- fprintf ff "@[<v 8>| %s ->@," (to_record_str fnlist fvlist);
- List.iter2 (fun letv (fv, ft) ->
- let_bind ff venv letv fv ft
- ) letvlist (List.combine fvlist ftlist);
- fprintf ff "Json_object %s@]@,)" (to_object_str fnlist letvlist)
- | C_variant cdlist ->
- fprintf ff "(match %s with@," v;
- List.iter (fun cd -> variant ff venv cd) cdlist;
- fprintf ff ")"
-
- and variant ff venv (CD_tuple (vname, vtlist)) =
- let vlist, venv = Var_env.new_idents_from_types venv vtlist in
- let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"j_" vlist in
- if List.length vlist = 0 then
- fprintf ff "@[<v 8>| %s ->@," vname
- else
- fprintf ff "@[<v 8>| %s (%s) ->@," vname (prod_vars_to_str vlist);
- List.iter2 (fun letv (v, vt) ->
- let_bind ff venv letv v vt
- ) letvlist (List.combine vlist vtlist);
- fprintf ff "Json_array %s@]@," (to_array_str ~constr:vname letvlist)
-
- and let_bind ff venv letv inv typ =
- fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
- to_json ff venv inv typ;
- fprintf ff " in@]@,"
-
- let def ff venv fn_name typ recd =
- let fnv, venv = Var_env.new_ident_from_name venv fn_name in
- let inv, venv = Var_env.new_ident_from_name venv "o" in
- let decl = match recd with First -> "let rec" | Next -> "and" in
- fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
- to_json ff venv inv typ;
- fprintf ff "@]@,@\n@?"
-end
-
-module From = struct
- let to_tuple_str ?(constr="") vlist =
- let elems = List.map name_of_var vlist in
- let len = List.length elems in
- (match len with
- | 0 -> Printf.sprintf "%s" constr
- | 1 -> Printf.sprintf "%s %s" constr (List.hd elems)
- | _ -> Printf.sprintf "%s (%s)" constr (String.concat ", " elems))
-
- let to_record_str fnlist fvlist =
- let fields = List.map2 (fun fn fv ->
- Printf.sprintf "%s = %s" fn (name_of_var fv)
- ) fnlist fvlist in
- "{ " ^ (String.concat "; " fields) ^ " }"
-
- let rec of_json ff venv inv typ tname =
- let v = name_of_var inv in
- match typ with
- | C_base bt ->
- (match bt with
- | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
- | _ -> ());
- fprintf ff "%s_of_json %s" (base_to_str bt) v
- | C_option optt ->
- let optv, venv = Var_env.new_ident_from_type venv optt in
- fprintf ff "(match %s with@," v;
- fprintf ff "| Json_null -> None@,";
- fprintf ff "@[<v 8>| %s -> @,Some (" (name_of_var optv);
- of_json ff venv optv optt tname;
- fprintf ff ")@]@,)"
- | C_list elemt ->
- let elemv, venv = Var_env.new_ident_from_type venv elemt in
- let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
- let oarrayvn = name_of_var oarrayv in
- fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
- fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- of_json ff venv elemv elemt tname;
- fprintf ff "@]@,) (get_array %s) in@]@," v;
- fprintf ff "Array.to_list %s" oarrayvn
- | C_array elemt ->
- let elemv, venv = Var_env.new_ident_from_type venv elemt in
- let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
- let oarrayvn = name_of_var oarrayv in
- fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
- fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- of_json ff venv elemv elemt tname;
- fprintf ff "@]@,) (get_array %s) in@]@," v;
- fprintf ff "%s" oarrayvn
- | C_tuple ctlist ->
- let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
- let jarrayvn = name_of_var jarrayv in
- let letvlist, venv = Var_env.new_idents_from_types venv ctlist in
- fprintf ff "let %s = get_array %s in@," jarrayvn v;
- fprintf ff "check_array_with_length %s %d;@," jarrayvn (List.length ctlist);
- ignore (List.fold_left (fun indx (letv, ct) ->
- let inv, venv = Var_env.new_ident_from_name venv "tindx" in
- fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) jarrayvn indx;
- let_bind ff venv letv inv ct tname;
- indx + 1
- ) 0 (List.combine letvlist ctlist));
- fprintf ff "%s" (to_tuple_str letvlist)
- | C_record cls ->
- let fnlist, ftlist = List.split cls in
- let letvlist, venv = Var_env.new_idents_from_types venv ftlist in
- let objtv, venv = Var_env.new_ident_from_name venv v ~suffix:"_ftable" in
- let objtvn = name_of_var objtv in
- fprintf ff "let %s = get_object_table %s in@," objtvn v;
- List.iter2 (fun letv (fn, ft) ->
- let fvar, venv = Var_env.new_ident_from_name venv ~suffix:"_f" fn in
- let optional = match ft with C_option _ -> "optional_" | _ -> "" in
- fprintf ff "let %s = get_%sobject_field %s \"%s\" in@," (name_of_var fvar) optional objtvn fn;
- let_bind ff venv letv fvar ft tname
- ) letvlist cls;
- fprintf ff "%s" (to_record_str fnlist letvlist)
- | C_variant cdlist ->
- let consv, venv = Var_env.new_ident_from_name venv "cons" in
- let consvn = name_of_var consv in
- let argsv, venv = Var_env.new_ident_from_name venv "args" in
- let defmatchv, venv = Var_env.new_ident_from_name venv "s" in
- let defmatchvn = name_of_var defmatchv in
- fprintf ff "let %s, %s = get_variant_constructor %s in@,"
- consvn (name_of_var argsv) v;
- fprintf ff "(match %s with@," consvn;
- List.iter (fun cd -> variant ff venv argsv cd tname) cdlist;
- (* need to write a default match case *)
- fprintf ff "| %s -> raise_unknown_constructor \"%s\" %s@,)"
- defmatchvn tname defmatchvn
-
- and variant ff venv argsv (CD_tuple (vname, vtlist)) tname =
- let argsvn = name_of_var argsv in
- let vtlen = List.length vtlist in
- let vlist, venv = Var_env.new_idents_from_types venv vtlist in
- let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"o_" vlist in
- fprintf ff "@[<v 8>| \"%s\" ->@," vname;
- if vtlen > 0 then
- fprintf ff "check_array_with_length %s %d;@," argsvn (vtlen + 1);
- ignore (List.fold_left (fun indx (letv, vt) ->
- let inv, venv = Var_env.new_ident_from_name venv "aindx" in
- fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) argsvn indx;
- let_bind ff venv letv inv vt tname;
- indx + 1
- ) 1 (List.combine letvlist vtlist));
- fprintf ff "%s@]@," (to_tuple_str ~constr:vname letvlist)
-
- and let_bind ff venv letv inv typ tname =
- fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
- of_json ff venv inv typ tname;
- fprintf ff " in@]@,"
-
- let def ff venv fn_name (tname, typ) recd =
- let fnv, venv = Var_env.new_ident_from_name venv fn_name in
- let inv, venv = Var_env.new_ident_from_name venv "j" in
- let decl = match recd with First -> "let rec" | Next -> "and" in
- fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
- of_json ff venv inv typ tname;
- fprintf ff "@]@,@\n@?"
-end
-
-let generate_to_def ff is_and (tname, trep) =
- To.def ff Var_env.new_env (tname ^ "_to_json") trep is_and
-
-let generate_from_def ff is_and (tname, trep) =
- From.def ff Var_env.new_env (tname ^ "_of_json") (tname, trep) is_and
-
-let generate_header ff ifn =
- let md = Filename.basename (Filename.chop_extension ifn) in
- let call = String.concat " " (Array.to_list Sys.argv) in
- fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call;
- fprintf ff "open Json@\n";
- fprintf ff "open Json_conv@\n";
- fprintf ff "open %s@\n@\n" (String.capitalize md)
-
-let generate_one_defn ff td =
- match td with
- | [] -> ()
- | h :: t ->
- List.iter (fun (tname, _) -> add_known_type tname) td;
- generate_to_def ff First h;
- List.iter (generate_to_def ff Next) t;
- generate_from_def ff First h;
- List.iter (generate_from_def ff Next) t
-
-let generate defn_list ofn ifn =
- reset_known_types ();
- let op_flags = [ Open_wronly ; Open_creat; Open_trunc; Open_text ] in
- let oc = open_out_gen op_flags 0o444 ofn in
- let ff = formatter_of_out_channel oc in
- try
- generate_header ff ifn;
- List.iter (generate_one_defn ff) defn_list;
- close_out oc
- with Unknown_base_type id ->
- Printf.eprintf "Error: Unknown base type \"%s\"\n" id;
- close_out oc;
- Unix.unlink ofn
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Syntax
-open Parser
-open Lexing
-
-let show_syntax_error e l =
- let loc = Printf.sprintf "%s at line %d, char %d"
- l.pos_fname l.pos_lnum (l.pos_cnum - l.pos_bol) in
- let msg =
- match e with
- | Illegal_character c -> Printf.sprintf "Illegal character %c" c
- | Invalid_ident s -> Printf.sprintf "Invalid/unsupported identifier %s" s
- | Unsupported_type_constructor s -> Printf.sprintf "Unsupported type constructor %s" s
- | Unmatched_comment -> Printf.sprintf "Unmatched comment"
- | Unterminated_comment -> Printf.sprintf "Unterminated comment"
- in
- Printf.eprintf "%s: %s\n" loc msg;
- exit 1
-
-let show_parse_error lexbuf =
- let lxm = lexeme lexbuf in
- let loc = Printf.sprintf "%s at line %d, char %d"
- lexbuf.lex_curr_p.pos_fname lexbuf.lex_curr_p.pos_lnum
- (lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol) in
- (match lxm with
- | "" -> Printf.eprintf "%s: parsing error\n" loc
- | _ -> Printf.eprintf "%s: parsing error at \"%s\"\n" loc lxm);
- exit 1
-
-let parse_file file =
- let f = open_in file in
- let lexbuf = Lexing.from_channel f in
- try
- Lexer.init lexbuf file;
- Parser.defn_list Lexer.main lexbuf
- with
- | Syntax_error (e, l) ->
- show_syntax_error e l
- | Parsing.Parse_error ->
- show_parse_error lexbuf
-
-let default_output_filename f =
- let dir, base = Filename.dirname f, Filename.basename f in
- let stem = Filename.chop_extension base in
- Filename.concat dir (stem ^ "_json_conv.ml")
-
-let () =
- let input = ref "" in
- let output = ref "" in
-
- (* parse argv *)
- let larg = [
- ("-i", Arg.Set_string input, "input file");
- ("-o", Arg.Set_string output, "output file");
- ] in
- let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
- Arg.parse larg (fun s -> ()) usage_msg;
-
- if !output = "" then output := default_output_filename !input;
-
- match !input with
- | "" -> Printf.printf "%s\n" usage_msg
- | file -> Codegen.generate (parse_file file) !output !input
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Lexing
-open Syntax
-open Parser
-
-let comment_depth = ref 0
-let comment_start = ref dummy_pos
-
-let line_num = ref 0
-
-let init lexbuf fname =
- lexbuf.lex_curr_p <- { pos_fname = fname;
- pos_lnum = 1;
- pos_bol = 0;
- pos_cnum = 0 }
-
-let raise_syntax_error e loc =
- raise (Syntax_error (e, loc))
-
-}
-
-let letter = ['A'-'Z' 'a'-'z']
-
-(* The handling of '.' is a bit of a hack for now; not sure if it's
- really needed. *)
-let ident_first = letter | '_'
-let ident_others = letter | ['0'-'9'] | '_' | '\'' | '.'
-let ident = ident_first ident_others*
-
-rule main = parse
-| [' ' '\009' '\012' '\r']+ { main lexbuf }
-
-| ['\n'] { new_line lexbuf; main lexbuf}
-
-| "*)" { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
-
-| "(*" { comment_depth := 1; comment_start := lexeme_start_p lexbuf;
- comment lexbuf; main lexbuf }
-
-| eof { EOF }
-| "=" { EQUAL }
-| "*" { STAR }
-| ";" { SEMI }
-| ";;" { SEMISEMI }
-| ":" { COLON }
-| "|" { BAR }
-
-| "{" { LBRACE }
-| "}" { RBRACE }
-| "(" { LPAREN }
-| ")" { RPAREN }
-| "[" { LBRACK }
-| "]" { RBRACK }
-
-| "type" { TYPE }
-| "and" { AND }
-| "mutable" { MUTABLE }
-| "of" { OF }
-
-(* general identifiers. we could handle the '.' here. *)
-| ident
- { let str = lexeme lexbuf in
- match String.get str 0 with
- | 'A' .. 'Z' -> UIDENT str
- | 'a' .. 'z' -> LIDENT str
- | _ -> raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
- }
-| _ { raise_syntax_error (Illegal_character (lexeme_char lexbuf 0)) (lexeme_start_p lexbuf) }
-
-
-and comment = parse
-| "(*" { incr comment_depth; comment lexbuf }
-| "*)" { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
-| ['\n'] { new_line lexbuf; comment lexbuf }
-| eof { raise_syntax_error Unterminated_comment !comment_start }
-| _ { comment lexbuf }
+++ /dev/null
-/*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Syntax
-
-let raise_syntax_error e pos =
- raise (Syntax_error (e, pos))
-
-%}
-
-/* keywords */
-%token TYPE AND MUTABLE OF
-
-%token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK
-%token EQUAL STAR SEMI SEMISEMI COLON BAR
-%token EOF
-
-%token <string> UIDENT LIDENT
-
-%start defn_list
-
-%type <Syntax.type_defn list> defn_list
-
-%%
-
-defn_list:
-| defns EOF { List.rev $1 }
-;
-
-defns:
-| defns top_defn_term { $2 :: $1 }
-| /* epsilon */ { [] }
-;
-
-top_defn_term:
-| defn semi { $1 }
-
-defn:
-| TYPE eqn { [ $2 ] }
-
-| TYPE eqn AND defn_parts { $2 :: (List.rev $4) }
-
-defn_parts:
-| defn_parts AND eqn { $3 :: $1 }
-| eqn { [ $1 ] }
-
-eqn:
-| LIDENT EQUAL repn { ($1, $3) }
-;
-
-semi:
-| SEMISEMI {}
-| /* epsilon */ {}
-
-repn:
-| expr_or_tuple { $1 }
-| record { C_record (List.rev $1) }
-| variant { C_variant (List.rev $1) }
-
-expr_or_tuple:
-| expr { $1 }
-| expr STAR tuple { C_tuple ($1 :: (List.rev $3)) }
-
-tuple:
-| tuple STAR expr { $3 :: $1 }
-| expr { [ $1 ] }
-
-expr:
-| LPAREN expr_or_tuple RPAREN { $2 }
-
-| expr LIDENT
- { match $2 with
- | "option" -> C_option $1
- | "list" -> C_list $1
- | "array" -> C_array $1
- | s -> (raise_syntax_error
- (Unsupported_type_constructor s)
- (Parsing.rhs_start_pos 2))
- }
-| base { C_base $1 }
-
-base:
-| LIDENT { match $1 with
- | "string" -> B_string
- | "int" -> B_int
- | "int64" -> B_int64
- | "bool" -> B_bool
- | s -> B_ident s
- }
-/* TODO:
-| UIDENT { raise_syntax_error (Invalid_ident $1) }
-*/
-
-record:
-| LBRACE field_decls opt_semi RBRACE { $2 }
-
-field_decls:
-| field_decls SEMI field_decl { $3 :: $1 }
-| field_decl { [ $1 ] }
-
-opt_semi:
-| SEMI {}
-| /* epsilon */ {}
-
-field_decl:
-| LIDENT COLON expr_or_tuple { ($1, $3) }
-| MUTABLE LIDENT COLON expr_or_tuple { ($2, $4) }
-
-variant:
-| variant BAR constr { $3 :: $1 }
-| constr { [ $1 ] }
-| /* epsilon */ { [] }
-
-constr:
-| UIDENT { CD_tuple ($1, []) }
-| UIDENT OF expr { CD_tuple ($1, [ $3 ]) }
-
-| UIDENT OF expr STAR tuple { CD_tuple ($1, ($3 :: (List.rev $5))) }
-
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 syntax_error =
- | Illegal_character of char
- | Invalid_ident of string
- | Unsupported_type_constructor of string
- | Unmatched_comment
- | Unterminated_comment
-
-exception Syntax_error of syntax_error * Lexing.position
-
-type base_type =
- | B_string
- | B_int
- | B_int64
- | B_bool
- | B_ident of string
-
-type complex_type =
- | C_base of base_type
- | C_option of complex_type
- | C_list of complex_type
- | C_array of complex_type
- | C_tuple of complex_type list
- | C_record of (string * complex_type) list
- | C_variant of constr_decl list
-
-and constr_decl =
- | CD_tuple of string * complex_type list
-
-type type_defn = (string * complex_type) list
-
+++ /dev/null
-.PHONY: clean
-
-OCAMLFLAGS += -I .. -I ../..
-
-test_types_json_conv.ml: test_types.ml $(JSON_CONV)
- ../$(JSON_CONV_PROG) -i $< -o $@
-
-TESTER_FILES[] =
- test_types
- test_types_json_conv
- test_json_conv
-
-OCAML_LIBS[] +=
- ../../json
-
-TESTER_PROG = test_json_conv
-TESTER = $(OCamlProgram $(TESTER_PROG), $(TESTER_FILES))
-
-.DEFAULT: $(TESTER)
-
-clean:
- rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
-
+++ /dev/null
-open Test_types
-open Test_types_json_conv
-
-let do_print = ref false
-
-let test_list to_j of_j o_list =
- List.iter (fun t ->
- let j = to_j t in
- let o = of_j j in
- if !do_print then
- Printf.printf "testing of_j(to_j(.) == . for %s\n" (Json.json_to_string j);
- assert (o = t)
- ) o_list;
- let j_list = List.map to_j o_list in
- List.iter (fun t ->
- let o = of_j t in
- let j = to_j o in
- if !do_print then
- Printf.printf "testing to_j(of_j(.) == . for %s\n" (Json.json_to_string j);
- assert (j = t)
- ) j_list
-
-
-let check_base_type () =
- let bs = [ B_int 3;
- B_int64 1L;
- B_bool false;
- B_string "test"
- ] in
- test_list base_type_to_json base_type_of_json bs
-
-let check_simple_type () =
- let ss = [ S_int_option None;
- S_int_option (Some 2);
- S_int64_option (Some 0L);
- S_bool_option (Some true);
- S_string_option (Some "tset");
-
- S_int_list [ ];
- S_int_list [ 3; 2; -1 ];
- S_bool_list [ true; false; false; true; false ];
- S_int64_list [ 1L; -3L; 2L; 5L];
- S_string_list [ "iggy"; "franti"; "zappa" ];
-
- S_int_array [| |];
- S_int_array [| 1; 3; 2 |];
- S_bool_array [| false; true; false; false; true |];
- S_int64_array [| 1L; 3L; -2L; 5L |];
- S_string_array [| "iggy"; "franti"; "zappa" |]
- ] in
- test_list simple_type_to_json simple_type_of_json ss
-
-let check_record_type () =
- let rs = [ { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
-
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
-
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
- } ] in
- test_list record_type_to_json record_type_of_json rs
-
-let check_complex_type1 () =
- let cs = [ [| |];
- [| ([], true) |];
- [| ([4; 3; 1], false); ([1; 3; 4], true) |];
- ] in
- test_list complex_type1_to_json complex_type1_of_json cs
-
-let check_complex_type2 () =
- let cs = [ { record = { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
-
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
-
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
- };
- complex_type1 = [| ([4; 3; 1], false); ([1; 3; 4], true) |];
- }
- ] in
- test_list complex_type2_to_json complex_type2_of_json cs
-
-let parse_args () =
- let options = [("-print-value", Arg.Set do_print, " print output")] in
- let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
- Arg.parse (Arg.align options) (fun f -> ()) usage
-
-let _ =
- parse_args ();
- check_base_type ();
- check_simple_type ();
- check_record_type ();
- check_complex_type1 ();
- check_complex_type2 ()
-
+++ /dev/null
-
-type base_type =
- | B_int of int
- | B_int64 of int64
- | B_bool of bool
- | B_string of string
-
-type simple_type =
- | S_int_option of int option
- | S_int64_option of int64 option
- | S_bool_option of bool option
- | S_string_option of string option
-
- | S_int_list of int list
- | S_bool_list of bool list
- | S_int64_list of int64 list
- | S_string_list of string list
-
- | S_int_array of int array
- | S_bool_array of bool array
- | S_int64_array of int64 array
- | S_string_array of string array
-
-type record_type =
-{
- int: int;
- int64: int64;
- bool: bool;
- string: string;
-
- int_list: int list;
- int64_option_array: (int64 option) array;
- bool_array: bool array;
-
- prod_list: ((int * bool) list) * string;
-}
-
-
-type complex_type1 = ((int list) * bool) array
-
-type complex_type2 =
-{
- record: record_type;
- complex_type1: complex_type1;
-}
+++ /dev/null
-TOPLEVEL=../../..
-include $(TOPLEVEL)/common.make
-
-OCAMLINCLUDE += -I ..
-
-#GEN_JSON_CONV = $(TOPLEVEL)/libs/json/gen_json_conv/gen_json_conv
-#syntax_json_conv.ml: syntax.ml $(GEN_JSON_CONV)
-# $(GEN_JSON_CONV) -i $< -o $@
-
-#GENERATED_FILES = syntax_json_conv.ml
-
-gen_rpc_OBJS = syntax syntax_json_conv rpc_decl codegen gen_rpc
-gen_rpc_LIBS = unix.cmxa $(TOPLEVEL)/libs/json/json.cmxa
-
-ALL_OCAML_OBJS = $(gen_rpc_OBJS)
-
-OCAML_PROGRAM = gen_rpc
-PROGRAMS = $(OCAML_PROGRAM)
-
-all: $(PROGRAMS)
-
-bins: $(PROGRAMS)
-
-include $(TOPLEVEL)/Makefile.rules
-
+++ /dev/null
-.PHONY: clean
-
-syntax_json_conv.ml: syntax.ml $(JSON_CONV)
- ../gen_json_conv/$(JSON_CONV_PROG) -i $< -o $@
-
-OCAMLFLAGS += -I ..
-
-GEN_RPC_FILES[] =
- syntax
- syntax_json_conv
- rpc_decl
- codegen
- gen_rpc
-
-OCAML_LIBS += ../json
-
-GEN_RPC_PROG = gen_rpc
-GEN_RPC = $(OCamlProgram $(GEN_RPC_PROG), $(GEN_RPC_FILES))
-
-.DEFAULT: $(GEN_RPC)
-
-clean:
- rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
-
-.SUBDIRS: tests
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Syntax
-open Rpc_decl
-open Format
-
-type var = { stem: string; mark: int }
-
-let name_of_var v =
- match v.mark with
- | 0 -> Printf.sprintf "%s" v.stem
- | d -> Printf.sprintf "%s_%d" v.stem d
-
-module Var_env = struct
- module StringMap = Map.Make (struct type t = string let compare = compare end)
-
- type name_entry = { cur_mark: int; entries: var list; }
-
- let new_name_entry = { cur_mark = 0; entries = [] }
-
- let make_new_var name_entry name =
- let var = { stem = name; mark = name_entry.cur_mark} in
- var, { cur_mark = var.mark + 1; entries = var :: name_entry.entries }
-
- type t = name_entry StringMap.t
- let new_env = StringMap.empty
-
- let new_var env full_name =
- let var, new_entry = make_new_var (try StringMap.find full_name env
- with Not_found -> new_name_entry) full_name in
- var, (StringMap.add full_name new_entry env)
-
- let new_ident_from_name env ?(prefix="") ?(suffix="") stem =
- new_var env (prefix ^ stem ^ suffix)
-
- let new_idents_from_names env ?(prefix="") ?(suffix="") names =
- let vlist, env =
- List.fold_left (fun (vlist, env) n ->
- let v, env' = new_ident_from_name env ~prefix ~suffix n in
- (v :: vlist), env'
- ) ([], env) names in
- (List.rev vlist), env
-end
-
-
-module Server = struct
- let start_server ff s =
- fprintf ff "module %s =@\n" (String.capitalize s.server_name);
- fprintf ff "@[<v 8>struct@,"
-
- let end_server ff =
- fprintf ff "@]@\nend@\n@\n@?"
-
- let gen_dispatch_struct ff server rpc_list notif_list =
- let sig_name = (String.lowercase server.server_name) ^ "_impl" in
- fprintf ff "type %s =@\n" sig_name;
- fprintf ff "@[<v 8>{@,";
- fprintf ff "(* RPCs *)";
- List.iter (fun (rpc, resp) ->
- let sg = List.map (fun p -> p.param_type) rpc.rpc_request.request_params in
- let sg = sg @ [ resp.response_value.param_type ] in
- fprintf ff "@,%s: %s;" rpc.rpc_request.request_handler (String.concat " -> " sg)
- ) rpc_list;
- fprintf ff "@,@,(* Notifications *)";
- List.iter (fun n ->
- let sg = List.map (fun p -> p.param_type) n.rpc_request.request_params in
- let sg = sg @ [ "unit" ] in
- fprintf ff "@,%s: %s;" n.rpc_request.request_handler (String.concat " -> " sg)
- ) notif_list;
- fprintf ff "@,@,(* Exception error handler *)";
- fprintf ff "@,%s: exn -> Json_rpc.rpc_error" server.server_error_handler;
- fprintf ff "@]@\n}@\n@\n";
- sig_name
-
- let gen_param ff venv arrvn i p =
- let arg, venv = Var_env.new_ident_from_name venv p.param_name in
- fprintf ff "let %s = %s_of_json %s.(%d) in@," (name_of_var arg) p.param_type arrvn i;
- arg, venv
-
- let gen_request ff venv reqv impl_module rpc resp =
- let arrv, venv = Var_env.new_ident_from_name venv "params" in
- let arrvn, reqvn = name_of_var arrv, name_of_var reqv in
- let methname = rpc.rpc_request.request_handler in
- let params = rpc.rpc_request.request_params in
- fprintf ff "@[<v 8>| \"%s\" ->@," rpc.rpc_request.request_name;
- fprintf ff "let %s = Json_conv.get_array %s.Json_rpc.params in@," arrvn reqvn;
- fprintf ff "Json_conv.check_array_with_length %s %d;@," arrvn (List.length params);
- let paramsv, venv, _ =
- List.fold_left (fun (alist, venv, i) p ->
- let a, venv = gen_param ff venv arrvn i p in
- (a :: alist), venv, (i + 1)
- ) ([], venv, 0) params in
- let respv, venv = Var_env.new_ident_from_name venv "resp" in
- let respjv, venv = Var_env.new_ident_from_name venv "resp_j" in
- let respvn, respjvn = name_of_var respv, name_of_var respjv in
- let args_str = String.concat " " (List.map (fun v -> name_of_var v) (List.rev paramsv)) in
- fprintf ff "let %s = %s.%s %s in@," respvn impl_module methname args_str;
- fprintf ff "let %s = %s_to_json %s in@," respjvn resp.response_value.param_type respvn;
- fprintf ff "Json_rpc.Result { Json_rpc.result = %s }@]@," respjvn
-
- let gen_notification ff venv reqv impl_module rpc =
- let arrv, venv = Var_env.new_ident_from_name venv "params" in
- let arrvn, reqvn = name_of_var arrv, name_of_var reqv in
- let methname = rpc.rpc_request.request_handler in
- let params = rpc.rpc_request.request_params in
- fprintf ff "@[<v 8>| \"%s\" ->@," rpc.rpc_request.request_name;
- fprintf ff "let %s = Json_conv.get_array %s.Json_rpc.params in@," arrvn reqvn;
- fprintf ff "Json_conv.check_array_with_length %s %d;@," arrvn (List.length params);
- let paramsv, venv, _ =
- List.fold_left (fun (alist, venv, i) p ->
- let a, venv = gen_param ff venv arrvn i p in
- (a :: alist), venv, (i + 1)
- ) ([], venv, 0) params in
- let args_str = String.concat " " (List.map (fun v -> name_of_var v) (List.rev paramsv)) in
- fprintf ff "%s.%s %s@]@," impl_module methname args_str
-
- let gen_notification_dispatch ff venv server impl_module nlist =
- let dispv, venv = Var_env.new_ident_from_name venv "dispatch_notification" in
- let reqv, venv = Var_env.new_ident_from_name venv "req" in
- let implv, venv = Var_env.new_ident_from_name venv impl_module in
- let reqvn, implvn = name_of_var reqv, name_of_var implv in
- fprintf ff "@[<v 8>let %s (%s : %s) %s =@," (name_of_var dispv) implvn impl_module reqvn;
- fprintf ff "match %s.Json_rpc.method_name with@," reqvn;
- List.iter (fun n -> gen_notification ff venv reqv implvn n) nlist;
- fprintf ff "| _ -> raise (Json_rpc.JSONRPC_unknown_request %s.Json_rpc.method_name)@]@,@\n" reqvn
-
- let gen_rpc_dispatch ff venv server impl_module rpcs =
- let dispv, venv = Var_env.new_ident_from_name venv "dispatch_rpc" in
- let reqidjv, venv = Var_env.new_ident_from_name venv "req_id_j" in
- let reqv, venv = Var_env.new_ident_from_name venv "req" in
- let implv, venv = Var_env.new_ident_from_name venv impl_module in
- let pv, venv = Var_env.new_ident_from_name venv "payload" in
- let reqidjvn, reqvn, implvn, pvn = name_of_var reqidjv, name_of_var reqv, name_of_var implv, name_of_var pv in
- fprintf ff "@[<v 8>let %s (%s : %s) %s %s =@," (name_of_var dispv) implvn impl_module reqidjvn reqvn;
- fprintf ff "@[<v 8>let %s =@," pvn;
- fprintf ff "@[<v 8>(try@,";
- fprintf ff "match %s.Json_rpc.method_name with@," reqvn;
- List.iter (fun (rpc, resp) -> gen_request ff venv reqv implvn rpc resp) rpcs;
- fprintf ff "| _ -> raise (Json_rpc.JSONRPC_unknown_request %s.Json_rpc.method_name)@]@," reqvn;
- let ev, venv = Var_env.new_ident_from_name venv "e" in
- let errv, venv = Var_env.new_ident_from_name venv "err" in
- let evn, errvn = name_of_var ev, name_of_var errv in
- fprintf ff "@[<v 8> with %s ->@," evn;
- fprintf ff "let %s = %s.%s %s in@," errvn implvn server.server_error_handler evn;
- fprintf ff "Json_rpc.Error %s)@]@]@," errvn;
- fprintf ff "in@,";
- fprintf ff "Json_rpc.rpc_response_to_json (%s, %s)@]@,@\n" reqidjvn pvn
-
- let gen_dispatch ff impl_name =
- fprintf ff "@[<v 8>let dispatch (%s : %s) req_j =@," impl_name impl_name;
- fprintf ff "let req = Json_rpc.rpc_request_of_json req_j in@,";
- fprintf ff "match req.Json_rpc.request_id with@,";
- fprintf ff "| None -> ignore (dispatch_notification %s req); None@," impl_name;
- fprintf ff "| Some id -> Some (dispatch_rpc %s id req)@]@,@\n" impl_name
-end
-
-module Client = struct
- let start_maker ff s =
- let rpcid_maker = "Rpc_id_maker" in
- fprintf ff "module Make_%s_client (%s : Json_rpc.Rpc_id_generator) =@\n" (String.lowercase s.server_name) rpcid_maker ;
- fprintf ff "@[<v 8>struct";
- rpcid_maker
-
- let end_maker ff =
- fprintf ff "@]@\nend@\n@\n@?"
-
- let generate_rpc ff venv rpcid_maker s rpc =
- let params = rpc.rpc_request.request_params in
- let args = List.map (fun p -> p.param_name) params in
- let avlist, venv = Var_env.new_idents_from_names venv ~prefix:"o_" args in
- let vvlist, venv = Var_env.new_idents_from_names venv ~prefix:"j_" args in
- fprintf ff "@,@[<v 8>let jrpc_%s %s =@," rpc.rpc_request.request_name (String.concat " " (List.map name_of_var avlist));
- List.iter2 (fun p (a, v) ->
- fprintf ff "let %s = %s_to_json %s in@," (name_of_var v) p.param_type (name_of_var a)
- ) params (List.combine avlist vvlist);
- let rpcv, venv = Var_env.new_ident_from_name venv "rpc_id" in
- let rpcvn = name_of_var rpcv in
- let args_str = String.concat "; " (List.map name_of_var vvlist) in
- (match rpc.rpc_response with
- | None -> fprintf ff "let %s = None in@," rpcvn
- | Some _ -> fprintf ff "let %s = Some (%s.get_rpc_request_id ()) in@," rpcvn rpcid_maker);
- fprintf ff "@[<v 2>{ Json_rpc.request_id = %s;@," rpcvn;
- fprintf ff "Json_rpc.method_name = \"%s\";@," rpc.rpc_request.request_name;
- fprintf ff "Json_rpc.params = Json.Json_array (Array.of_list [ %s ])" args_str;
- fprintf ff "@]@,}@]"
-end
-
-let generate_header ff =
- let call = String.concat " " (Array.to_list Sys.argv) in
- fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call
-
-let generate_opens ff spec =
- List.iter (fun m -> fprintf ff "open %s@\n" (String.capitalize m)) (get_uses spec);
- fprintf ff "@\n"
-
-let open_output fn =
- let op_flags = [ Open_wronly ; Open_creat; Open_trunc; Open_text ] in
- let oc = open_out_gen op_flags 0o444 fn in
- let ff = formatter_of_out_channel oc in
- oc, ff
-
-let generate_server spec fn =
- let oc, ff = open_output fn in
- generate_header ff;
- generate_opens ff spec;
- List.iter (fun s ->
- Server.start_server ff s;
- let rpc_list, notif_list = get_sorted_rpcs_by_server spec s in
- let sig_name = Server.gen_dispatch_struct ff s rpc_list notif_list in
- Server.gen_rpc_dispatch ff Var_env.new_env s sig_name rpc_list;
- Server.gen_notification_dispatch ff Var_env.new_env s sig_name notif_list;
- Server.gen_dispatch ff sig_name;
- Server.end_server ff;
- fprintf ff "@\n@?"
- ) (get_servers spec);
- close_out oc
-
-let generate_client spec fn =
- let oc, ff = open_output fn in
- generate_header ff;
- generate_opens ff spec;
- List.iter (fun s ->
- let rpc_list = get_rpcs_by_server spec s in
- let rpcid_maker = Client.start_maker ff s in
- List.iter (Client.generate_rpc ff Var_env.new_env rpcid_maker s) rpc_list;
- Client.end_maker ff
- ) (get_servers spec);
- close_out oc
-
-let generate spec cfn sfn =
- generate_client spec cfn;
- generate_server spec sfn
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Json_parse
-open Json_conv
-open Syntax_json_conv
-
-let make_default_output_filename f suffix =
- let dir, base = Filename.dirname f, Filename.basename f in
- let stem = Filename.chop_extension base in
- Filename.concat dir (stem ^ suffix)
-
-let parse_args () =
- let input = ref "" in
- let client = ref "" in
- let server = ref "" in
- let options = [ ("-i", Arg.Set_string input, " input file");
- ("-c", Arg.Set_string client, " client interface");
- ("-s", Arg.Set_string server, " server interface")
- ] in
- let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
- let errmsg s = Printf.eprintf "%s\n" s; Arg.usage (Arg.align options) usage; exit 1 in
- Arg.parse (Arg.align options) (fun s -> input := s) usage;
- if !input = "" then errmsg "Unspecified input file!";
- if !client = "" then client := make_default_output_filename !input "_client.ml";
- if !server = "" then server := make_default_output_filename !input "_server.ml";
- !input, !client, !server
-
-let read_whole_file ic =
- let buf = Buffer.create 2048 in
- let str = String.create 1024 in
- let rec do_read () =
- (* Don't use input_line, since it does not preserve newlines. *)
- let read = input ic str 0 (String.length str) in
- match read with
- | 0 -> raise End_of_file
- | _ -> Buffer.add_substring buf str 0 read; do_read ()
- in
- try do_read () with End_of_file -> Buffer.contents buf
-
-let parse_file f =
- let rpc_decls = ref [] in
- let count = ref 1 in
- let ic = open_in f in
- let input = ref (read_whole_file ic) in
- let state = ref (init_parse_state ()) in
- while String.length !input > 0 do
- match parse !state !input with
- | Json_value (v, rem) ->
- rpc_decls := (!count, v) :: !rpc_decls;
- incr count;
- input := rem;
- state := init_parse_state ()
- | Json_parse_incomplete st ->
- input := "";
- state := st
- done;
- (match finish_parse !state with
- | Some v -> rpc_decls := (!count, v) :: !rpc_decls;
- | None -> ());
- List.rev !rpc_decls
-
-
-exception Unknown_rpc_decl of int * Json.t
-exception Invalid_rpc_decl of int * (* type *) string * (* msg *) string
-
-let get_conv_err_msg err =
- match err with
- | Unexpected_json_type (r, e) ->
- Printf.sprintf "type %s received when %s was expected" r e
- | Array_length (r, e) ->
- Printf.sprintf "array length %d received when %d was expected" r e
- | Unknown_constructor (t, c) ->
- Printf.sprintf "unknown constructor %s received for type %s" c t
- | Missing_object_field f ->
- Printf.sprintf "missing object field %s" f
-
-let print_exception e =
- let msg =
- match e with
- | Unexpected_char (l, c, state) ->
- Printf.sprintf "Line %d: Unexpected char %C (x%X) encountered in state %s"
- l c (Char.code c) state
- | Invalid_value (l, v, t) ->
- Printf.sprintf "Line %d: '%s' is an invalid %s" l v t
- | Invalid_leading_zero (l, s) ->
- Printf.sprintf "Line %d: '%s' should not have leading zeros" l s
- | Unterminated_value (l, s) ->
- Printf.sprintf "Line %d: unterminated %s" l s
- | Internal_error (l, m) ->
- Printf.sprintf "Line %d: Internal error: %s" l m
- | Json_conv_failure err ->
- Printf.sprintf "Conversion error: %s" (get_conv_err_msg err)
- | Unknown_rpc_decl (i, j) ->
- Printf.sprintf "Rpc declaration #%d is of unknown type." i
- | Invalid_rpc_decl (i, n, m) ->
- Printf.sprintf "Error parsing decl %d for %s: %s" i n m
- | Sys_error s ->
- Printf.sprintf "%s" s
- | e ->
- Printf.sprintf "%s" (Printexc.to_string e)
- in
- Printf.eprintf "%s\n" msg
-
-let process_jdecl (i, j) =
- if not (Json.is_object j) then
- raise (Unknown_rpc_decl (i, j));
- let obj = get_object_table j in
- if (is_object_field_present obj "use_modules") then
- try Rpc_decl.Rpc_use (use_of_json j)
- with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "use", (get_conv_err_msg err)))
- else if (is_object_field_present obj "server_name") then
- try Rpc_decl.Rpc_server (server_of_json j)
- with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "server", (get_conv_err_msg err)))
- else if (is_object_field_present obj "rpc_type") then
- try Rpc_decl.Rpc_rpc (rpc_of_json j)
- with Json_conv_failure err -> raise (Invalid_rpc_decl (i, "rpc", (get_conv_err_msg err)))
- else
- raise (Unknown_rpc_decl (i, j))
-
-let _ =
- let input, client, server = parse_args () in
- try
- let jdecls = parse_file input in
- Printf.printf "%d decls parsed.\n" (List.length jdecls);
- let decls = List.map process_jdecl jdecls in
- let spec = Rpc_decl.spec_with_decls decls in
- Codegen.generate spec client server;
- exit 0
- with e ->
- print_exception e;
- exit 1
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 Syntax
-
-type decl =
- | Rpc_use of use
- | Rpc_server of server
- | Rpc_rpc of rpc
-
-type elem = Server | RPC
-
-let elem_name = function Server -> "server" | RPC -> "rpc"
-
-type spec =
-{
- uses: string list;
- servers: server list;
- rpcs: rpc list;
-}
-
-let init_spec =
-{
- uses = [];
- servers = [];
- rpcs = []
-}
-
-let get_rpcs_by_server spec server =
- List.rev (List.filter (fun r -> r.rpc_server = server.server_name) spec.rpcs)
-
-let get_sorted_rpcs_by_server spec server =
- let rpcs = List.filter (fun r -> r.rpc_server = server.server_name) spec.rpcs in
- let rlist, nlist =
- List.fold_left (fun (rlist, nlist) rpc ->
- match rpc.rpc_response with
- | None -> rlist, rpc :: nlist
- | Some r -> (rpc, r) :: rlist, nlist
- ) ([], []) rpcs
- in rlist, nlist
-
-exception Multiple_decl of elem * string
-exception Unknown_ref of elem * string
-exception Unknown_RPC_type of string
-exception Notification_has_response of string
-exception RPC_needs_response of string
-
-let present spec elem name =
- try
- match elem with
- | Server -> ignore (List.find (fun s -> s.server_name = name) spec.servers); true
- | RPC -> ignore (List.find (fun r -> (r.rpc_server ^ "." ^ r.rpc_request.request_name) = name) spec.rpcs); true
- with Not_found -> false
-
-let check_new spec elem name =
- if present spec elem name then raise (Multiple_decl (elem, name))
-
-let check_existing spec elem name =
- if not (present spec elem name) then raise (Unknown_ref (elem, name))
-
-let add_use spec u =
- List.fold_left (fun spec m ->
- if not (List.mem m spec.uses)
- then { spec with uses = m :: spec.uses }
- else spec
- ) spec u.use_modules
-
-let get_uses spec = List.rev spec.uses
-
-let add_server spec s =
- check_new spec Server s.server_name;
- { spec with servers = s :: spec.servers }
-
-let get_servers spec = List.rev spec.servers
-
-let add_rpc spec r =
- let name = r.rpc_request.request_name in
- check_new spec RPC (r.rpc_server ^ "." ^ name);
- check_existing spec Server r.rpc_server;
- (match r.rpc_type with
- | "notification" | "Notification" ->
- if r.rpc_response <> None then
- raise (Notification_has_response name)
- | "rpc" | "RPC" ->
- if r.rpc_response = None then
- raise (RPC_needs_response name)
- | s -> raise (Unknown_RPC_type s));
- { spec with rpcs = r :: spec.rpcs }
-
-let add_decl spec = function
- | Rpc_use u -> add_use spec u
- | Rpc_server s -> add_server spec s
- | Rpc_rpc r -> add_rpc spec r
-
-let error_message e =
- match e with
- | Multiple_decl (e, n) ->
- Printf.sprintf "Repeated declaration of %s \"%s\"" (elem_name e) n
- | Unknown_ref (e, n) ->
- Printf.sprintf "Reference to unknown %s \"%s\"" (elem_name e) n
- | Notification_has_response n ->
- Printf.sprintf "Notification \"%s\" cannot specify a response" n
- | RPC_needs_response n ->
- Printf.sprintf "RPC \"%s\" needs a response specification" n
- | e -> raise e
-
-let spec_with_decls decls =
- try
- List.fold_left (fun spec d -> add_decl spec d) init_spec decls
- with e ->
- Printf.eprintf "%s\n" (error_message e);
- exit 1
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * 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 use =
-{
- use_modules: string list;
-}
-
-type server =
-{
- server_name: string;
- server_doc: string;
- server_error_handler: string;
-}
-
-type param =
-{
- param_name: string;
- param_doc: string;
- param_type: string;
-}
-
-type request =
-{
- request_name: string;
- request_doc: string;
- request_handler: string;
- request_params: param list;
-}
-
-type response =
-{
- response_doc: string;
- response_handler: string;
- response_value: param;
-}
-
-type rpc =
-{
- rpc_type: string;
- rpc_server: string;
- rpc_doc: string;
- rpc_version: string;
-
- rpc_deprecated: string option;
- rpc_label_arguments: bool option;
-
- rpc_request: request;
- rpc_response: response option;
-}
-
+++ /dev/null
-(* This file has been auto-generated using "/home/prashanth/xenclient/build/repo/xenclient-toolstack/libs/json/gen_json_conv/gen_json_conv -i syntax.ml -o syntax_json_conv.ml". *)
-
-open Json_conv
-open Syntax
-
-let rec use_to_json o =
- (match o with
- | { use_modules = lst } ->
- let j_lst =
- let lst_jlist = List.map
- (fun str ->
- string_to_json str
- ) lst in
- Json.Array (Array.of_list lst_jlist) in
- Json.Object [| ("use_modules", j_lst) |]
- )
-
-let rec use_of_json j =
- let j_ftable = get_object_table j in
- let use_modules_f = get_object_field j_ftable "use_modules" in
- let lst =
- let use_modules_f_oarray = Array.map
- (fun str ->
- string_of_json str
- ) (get_array use_modules_f) in
- Array.to_list use_modules_f_oarray in
- { use_modules = lst }
-
-let rec server_to_json o =
- (match o with
- | { server_name = str; server_doc = str_1; server_error_handler = str_2 } ->
- let j_str =
- string_to_json str in
- let j_str_1 =
- string_to_json str_1 in
- let j_str_2 =
- string_to_json str_2 in
- Json.Object [| ("server_name", j_str); ("server_doc", j_str_1); ("server_error_handler", j_str_2) |]
- )
-
-let rec server_of_json j =
- let j_ftable = get_object_table j in
- let server_name_f = get_object_field j_ftable "server_name" in
- let str =
- string_of_json server_name_f in
- let server_doc_f = get_object_field j_ftable "server_doc" in
- let str_1 =
- string_of_json server_doc_f in
- let server_error_handler_f = get_object_field j_ftable "server_error_handler" in
- let str_2 =
- string_of_json server_error_handler_f in
- { server_name = str; server_doc = str_1; server_error_handler = str_2 }
-
-let rec param_to_json o =
- (match o with
- | { param_name = str; param_doc = str_1; param_type = str_2 } ->
- let j_str =
- string_to_json str in
- let j_str_1 =
- string_to_json str_1 in
- let j_str_2 =
- string_to_json str_2 in
- Json.Object [| ("param_name", j_str); ("param_doc", j_str_1); ("param_type", j_str_2) |]
- )
-
-let rec param_of_json j =
- let j_ftable = get_object_table j in
- let param_name_f = get_object_field j_ftable "param_name" in
- let str =
- string_of_json param_name_f in
- let param_doc_f = get_object_field j_ftable "param_doc" in
- let str_1 =
- string_of_json param_doc_f in
- let param_type_f = get_object_field j_ftable "param_type" in
- let str_2 =
- string_of_json param_type_f in
- { param_name = str; param_doc = str_1; param_type = str_2 }
-
-let rec request_to_json o =
- (match o with
- | { request_name = str; request_doc = str_1; request_handler = str_2; request_params = lst } ->
- let j_str =
- string_to_json str in
- let j_str_1 =
- string_to_json str_1 in
- let j_str_2 =
- string_to_json str_2 in
- let j_lst =
- let lst_jlist = List.map
- (fun param ->
- param_to_json param
- ) lst in
- Json.Array (Array.of_list lst_jlist) in
- Json.Object [| ("request_name", j_str); ("request_doc", j_str_1); ("request_handler", j_str_2); ("request_params", j_lst) |]
- )
-
-let rec request_of_json j =
- let j_ftable = get_object_table j in
- let request_name_f = get_object_field j_ftable "request_name" in
- let str =
- string_of_json request_name_f in
- let request_doc_f = get_object_field j_ftable "request_doc" in
- let str_1 =
- string_of_json request_doc_f in
- let request_handler_f = get_object_field j_ftable "request_handler" in
- let str_2 =
- string_of_json request_handler_f in
- let request_params_f = get_object_field j_ftable "request_params" in
- let lst =
- let request_params_f_oarray = Array.map
- (fun param ->
- param_of_json param
- ) (get_array request_params_f) in
- Array.to_list request_params_f_oarray in
- { request_name = str; request_doc = str_1; request_handler = str_2; request_params = lst }
-
-let rec response_to_json o =
- (match o with
- | { response_doc = str; response_handler = str_1; response_value = param } ->
- let j_str =
- string_to_json str in
- let j_str_1 =
- string_to_json str_1 in
- let j_param =
- param_to_json param in
- Json.Object [| ("response_doc", j_str); ("response_handler", j_str_1); ("response_value", j_param) |]
- )
-
-let rec response_of_json j =
- let j_ftable = get_object_table j in
- let response_doc_f = get_object_field j_ftable "response_doc" in
- let str =
- string_of_json response_doc_f in
- let response_handler_f = get_object_field j_ftable "response_handler" in
- let str_1 =
- string_of_json response_handler_f in
- let response_value_f = get_object_field j_ftable "response_value" in
- let param =
- param_of_json response_value_f in
- { response_doc = str; response_handler = str_1; response_value = param }
-
-let rec rpc_to_json o =
- (match o with
- | { rpc_type = str; rpc_server = str_1; rpc_doc = str_2; rpc_version = str_3; rpc_deprecated = opt; rpc_label_arguments = opt_1; rpc_request = request; rpc_response = opt_2 } ->
- let j_str =
- string_to_json str in
- let j_str_1 =
- string_to_json str_1 in
- let j_str_2 =
- string_to_json str_2 in
- let j_str_3 =
- string_to_json str_3 in
- let j_opt =
- (match opt with
- | None -> Json.Null
- | Some str_4 ->
- string_to_json str_4
- ) in
- let j_opt_1 =
- (match opt_1 with
- | None -> Json.Null
- | Some bool ->
- bool_to_json bool
- ) in
- let j_request =
- request_to_json request in
- let j_opt_2 =
- (match opt_2 with
- | None -> Json.Null
- | Some response ->
- response_to_json response
- ) in
- Json.Object [| ("rpc_type", j_str); ("rpc_server", j_str_1); ("rpc_doc", j_str_2); ("rpc_version", j_str_3); ("rpc_deprecated", j_opt); ("rpc_label_arguments", j_opt_1); ("rpc_request", j_request); ("rpc_response", j_opt_2) |]
- )
-
-let rec rpc_of_json j =
- let j_ftable = get_object_table j in
- let rpc_type_f = get_object_field j_ftable "rpc_type" in
- let str =
- string_of_json rpc_type_f in
- let rpc_server_f = get_object_field j_ftable "rpc_server" in
- let str_1 =
- string_of_json rpc_server_f in
- let rpc_doc_f = get_object_field j_ftable "rpc_doc" in
- let str_2 =
- string_of_json rpc_doc_f in
- let rpc_version_f = get_object_field j_ftable "rpc_version" in
- let str_3 =
- string_of_json rpc_version_f in
- let rpc_deprecated_f = get_optional_object_field j_ftable "rpc_deprecated" in
- let opt =
- (match rpc_deprecated_f with
- | Json.Null -> None
- | str_4 ->
- Some (string_of_json str_4)
- ) in
- let rpc_label_arguments_f = get_optional_object_field j_ftable "rpc_label_arguments" in
- let opt_1 =
- (match rpc_label_arguments_f with
- | Json.Null -> None
- | bool ->
- Some (bool_of_json bool)
- ) in
- let rpc_request_f = get_object_field j_ftable "rpc_request" in
- let request =
- request_of_json rpc_request_f in
- let rpc_response_f = get_optional_object_field j_ftable "rpc_response" in
- let opt_2 =
- (match rpc_response_f with
- | Json.Null -> None
- | response ->
- Some (response_of_json response)
- ) in
- { rpc_type = str; rpc_server = str_1; rpc_doc = str_2; rpc_version = str_3; rpc_deprecated = opt; rpc_label_arguments = opt_1; rpc_request = request; rpc_response = opt_2 }
-
+++ /dev/null
-.PHONY: clean
-
-rpc_types_json_conv.ml: rpc_types.ml $(JSON_CONV)
- ../../gen_json_conv/$(JSON_CONV_PROG) -i $< -o $@
-
-rpc_defns_client.ml rpc_defns_server.ml: rpc_defns.json $(GEN_RPC)
- ../$(GEN_RPC_PROG) $<
-
-OCAMLFLAGS += -I ../..
-
-RPC_TEST_FILES[] =
- rpc_types
- rpc_types_json_conv
- rpc_defns_client
- rpc_defns_server
- test_rpc
-
-
-OCAML_LIBS = ../../json
-
-RPC_TEST_PROG = test
-RPC_TEST = $(OCamlProgram $(RPC_TEST_PROG), $(RPC_TEST_FILES))
-
-.DEFAULT: $(RPC_TEST)
-
-clean:
- rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo rpc_defns_client.ml rpc_defns_server.ml
-
+++ /dev/null
-{ "use_modules": ["rpc_types", "rpc_types_json_conv"]}
-
-{ "server_name": "server",
- "server_doc": "",
- "server_error_handler": "server_error_handler"
-}
-
-{ "rpc_type": "rpc",
- "rpc_server": "server",
- "rpc_doc": "documentation",
- "rpc_version": "string",
-
- "rpc_request": { "request_name": "request1",
- "request_doc": "documentation",
- "request_handler": "request1_handler",
- "request_params": [ { "param_name": "request1_arg1",
- "param_doc": "documentation",
- "param_type": "arg1_type"
- }
- ]
- },
-
- "rpc_response": { "response_doc": "documentation",
- "response_handler": "response1_handler",
- "response_value": { "param_name": "resp1",
- "param_doc": "documentation",
- "param_type": "resp1_type"
- }
- },
-
- "rpc_deprecated": "string",
- "rpc_label_arguments": false
-}
-
-{ "rpc_type": "rpc",
- "rpc_server": "server",
- "rpc_doc": "documentation",
- "rpc_version": "string",
-
- "rpc_request": { "request_name": "request2",
- "request_doc": "documentation",
- "request_handler": "request2_handler",
- "request_params": [ { "param_name": "arg1",
- "param_doc": "documentation",
- "param_type": "arg1_type"
- },
- { "param_name": "arg2",
- "param_doc": "documentation",
- "param_type": "arg2_type"
- },
- { "param_name": "arg3",
- "param_doc": "documentation",
- "param_type": "arg3_type"
- }
- ]
- },
-
- "rpc_response": { "response_doc": "documentation",
- "response_handler": "client_function",
- "response_value": { "param_name": "resp2",
- "param_doc": "documentation",
- "param_type": "resp2_type"
- }
- },
-
- "rpc_label_arguments": true
-}
-
-{ "rpc_type": "notification",
- "rpc_server": "server",
- "rpc_doc": "documentation",
- "rpc_version": "string",
-
- "rpc_request": { "request_name": "notification1",
- "request_doc": "documentation",
- "request_handler": "not1_handler",
- "request_params": [ { "param_name": "arg1",
- "param_doc": "documentation",
- "param_type": "arg1_type"
- },
- { "param_name": "arg2",
- "param_doc": "documentation",
- "param_type": "arg2_type"
- },
- { "param_name": "arg3",
- "param_doc": "documentation",
- "param_type": "arg3_type"
- }
- ]
- }
-}
-
-{ "server_name": "server1",
- "server_doc": "",
- "server_error_handler": "server1_error_handler"
-}
-
-{ "rpc_type": "rpc",
- "rpc_server": "server1",
- "rpc_doc": "documentation",
- "rpc_version": "string",
-
- "rpc_request": { "request_name": "request2",
- "request_doc": "documentation",
- "request_handler": "request2_handler",
- "request_params": [ { "param_name": "arg1",
- "param_doc": "documentation",
- "param_type": "arg1_type"
- },
- { "param_name": "arg2",
- "param_doc": "documentation",
- "param_type": "arg2_type"
- },
- { "param_name": "arg3",
- "param_doc": "documentation",
- "param_type": "arg3_type"
- }
- ]
- },
-
- "rpc_response": { "response_doc": "documentation",
- "response_handler": "client_function",
- "response_value": { "param_name": "resp2",
- "param_doc": "documentation",
- "param_type": "resp2_type"
- }
- },
-
- "rpc_label_arguments": true
-}
+++ /dev/null
-
-type arg1_type = int
-
-type arg2_type = (string * arg1_type) list
-
-type arg3_type = bool
-
-type resp1_type = bool option
-
-type resp2_type = string
+++ /dev/null
-open Rpc_types
-open Rpc_types_json_conv
-open Rpc_defns_server
-open Rpc_defns_client
-
-(* First, implement the Json-rpc id generator. *)
-module I : Json_rpc.Rpc_id_generator = struct
- let cur_id = ref 0L
-
- let get_rpc_request_id () =
- let id = !cur_id in
- cur_id := Int64.add !cur_id 1L;
- Json.Json_int id
-end
-
-(* Now, create the client-side wrappers. *)
-
-module C = Make_server_client (I)
-
-(* Finally, implement the server-side call dispatch structure. *)
-module S = struct
- let req1_handler arg1 =
- if arg1 < 5 then None
- else if arg1 < 10 then Some false
- else Some true
-
- let req2_handler arg1 arg2 arg3 =
- ((string_of_int arg1)
- ^ ".[" ^ (String.concat "," (List.map (fun (s, i) -> s ^ "-" ^ (string_of_int i)) arg2))
- ^ "]." ^ (if arg3 then "true" else "false"))
-
- let not1_handler arg1 arg2 arg3 =
- assert ((arg1 = 5)
- && (arg2 = ["5", 5; "10", 10])
- && arg3)
-
- let error_handler e =
- { Json_rpc.code = 2;
- Json_rpc.message = Printexc.to_string e;
- Json_rpc.data = Some (Json.Json_string "details")
- }
-
- let server_impl =
- { Server.request1_handler = req1_handler;
- Server.request2_handler = req2_handler;
- Server.not1_handler = not1_handler;
- Server.server_error_handler = error_handler
- }
-end
-
-let rpc_invoke req resp_fun =
- (* Client-side request processing: *)
-
- (* 1) create the corresponding json-rpc request object to send over the wire. *)
- let jreq_c = Json_rpc.rpc_request_to_json req in
-
- (* 2) send it over the wire. *)
- let jnet_c = Json.json_to_string jreq_c in
- let _ = Printf.printf "Sending request: %s\n" jnet_c in
-
- (* Server-side processing: *)
-
- (* i) parse the string into a json value *)
- let ps = Json_parse.init_parse_state () in
- let jreq_s = match Json_parse.parse ps jnet_c with
- | Json_parse.Json_value (j, _) -> j
- | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
-
- (* ii) dispatch the request *)
- let resp_j = Server.dispatch S.server_impl jreq_s in
-
- (* iii) check whether we have a response to send back *)
- let resp_j = match resp_j with
- | None -> raise (Failure "unexpected notification")
- | Some j -> j in
-
- (* iv) send it over the wire *)
- let jnet_s = Json.json_to_string resp_j in
- let _ = Printf.printf "Sending response: %s\n" jnet_s in
-
- (* Client-side response processing: *)
-
- (* a) parse the string into a json value *)
- let pc = Json_parse.init_parse_state () in
- let jresp_c = match Json_parse.parse pc jnet_s with
- | Json_parse.Json_value (j, _) -> j
- | Json_parse.Json_parse_incomplete _ -> raise (Failure "client json parsing") in
-
- (* b) extract the response *)
- let resp = Json_rpc.rpc_response_of_json jresp_c in
-
- (* c) process that response *)
- resp_fun resp
-
-let notification_invoke testname req =
- (* Client-side request processing: *)
-
- (* 1) create the corresponding json-rpc request object to send over the wire. *)
- let jreq_c = Json_rpc.rpc_request_to_json req in
-
- (* 2) send it over the wire. *)
- let jnet_c = Json.json_to_string jreq_c in
- let _ = Printf.printf "Sending request: %s\n" jnet_c in
-
- (* Server-side processing: *)
-
- (* i) parse the string into a json value *)
- let ps = Json_parse.init_parse_state () in
- let jreq_s = match Json_parse.parse ps jnet_c with
- | Json_parse.Json_value (j, _) -> j
- | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
-
- (* ii) dispatch the request *)
- let resp_j = Server.dispatch S.server_impl jreq_s in
-
- (* iii) check whether we have a response to send back *)
- (match resp_j with
- | None -> ()
- | Some j -> raise (Failure (Printf.sprintf "unexpected response in test %s" testname)))
-
-
-let default_id_check req_id resp_id =
- match req_id with
- | None -> if not (Json.is_null resp_id) then raise (Failure "unexpected non-null resp id received")
- | Some id -> if (id <> resp_id) then raise (Failure "resp id differs from req id")
-
-let default_error_check e =
- raise (Failure "unexpected rpc error received.")
-
-let test_invoke req ?(id_check=default_id_check) ?(error_check=default_error_check) result_check =
- let resp_fun (resp_id, resp) =
- id_check req.Json_rpc.request_id resp_id;
- match resp with
- | Json_rpc.Result r -> result_check r
- | Json_rpc.Error e -> error_check e
- in
- rpc_invoke req resp_fun
-
-let test_server () =
- let req1_checker test_id arg1 =
- let req = C.jrpc_request1 arg1 in
- let exp_resp = S.req1_handler arg1 in
- let resp_to_str r = match r with |None -> "None" | Some b -> if b then "Some true" else "Some false" in
- let resp_checker r =
- let got_resp = resp1_type_of_json r.Json_rpc.result in
- if got_resp <> exp_resp
- then raise (Failure (Printf.sprintf "req1, test %s: got \"%s\", expected \"%s\"!"
- test_id (resp_to_str got_resp) (resp_to_str exp_resp)))
- in
- test_invoke req resp_checker
- in
- req1_checker "1" 3;
- req1_checker "2" 7;
- req1_checker "3" 13;
-
- let req2_checker test_id arg1 arg2 arg3 =
- let req = C.jrpc_request2 arg1 arg2 arg3 in
- let exp_resp = S.req2_handler arg1 arg2 arg3 in
- let resp_checker r =
- let got_resp = resp2_type_of_json r.Json_rpc.result in
- if got_resp <> exp_resp
- then raise (Failure (Printf.sprintf "req2, test %s: got \"%s\", expected \"%s\"!" test_id got_resp exp_resp))
- in
- test_invoke req resp_checker
- in
- req2_checker "1" 1 [] true;
- req2_checker "2" 2 [("2", 2)] true;
- req2_checker "3" 5 [("2", 2); ("9", 6)] false;
-
- let notif = C.jrpc_notification1 5 ["5", 5; "10", 10] true in
- notification_invoke "not1: case 1" notif
-
-let _ =
- test_server ()
projects / xenclient / toolstack.git / commitdiff