OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
OCAMLFLAGS = -annot
+PACKS = xmlm
ICAMLP4=-I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv)
.PHONY: all clean
-all: pa_rpc.cma xmlrpc.cma xmlrpc.cmxa
+all: pa_rpc.cma xmlrpc.cmi xmlrpc.cma xmlrpc.cmxa jsonrpc.cmi jsonrpc.cmxa jsonrpc.cma
+
pa_rpc.cma: rpc.cmo pa_rpc.cmo
$(OCAMLC) -a $(ICAMLP4) -o $@ $^
-xmlrpc.cmxa: rpc.cmx xmlrpc.cmx
+pa_rpc.cmo: pa_rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
+
+
+
+rpc.cmx: rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
+
+rpc.cmo: rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+
+
+%.cmxa: rpc.cmx %.cmx
$(OCAMLOPT) -a -o $@ $^
-xmlrpc.cma: rpc.cmo xmlrpc.cmo
+%.cma: rpc.cmo %.cmo
$(OCAMLC) -a -o $@ $^
-xmlrpc.cmx: xmlrpc.ml xmlrpc.cmi
- $(OCAMLOPT) $(OCAMLFLAGS) -c -I ../xml-light2 -o $@ $<
-xmlrpc.cmo: xmlrpc.ml xmlrpc.cmi
- $(OCAMLC) $(OCAMLFLAGES) -c -I ../xml-light2 -o $@ $<
+xmlrpc.cmx: xmlrpc.ml xmlrpc.cmi rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-xmlrpc.cmi: xmlrpc.mli
- $(OCAMLOPT) $(OCAMLFLAGS) -c -I ../xml-light2 -o $@ $<
+xmlrpc.cmo: xmlrpc.ml xmlrpc.cmi rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
+xmlrpc.cmi: xmlrpc.mli rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-rpc.cmx: rpc.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
-rpc.cmo: rpc.ml
- $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+jsonrpc.cmx: jsonrpc.ml jsonrpc.cmi rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
+jsonrpc.cmo: jsonrpc.ml jsonrpc.cmi rpc.ml
+ $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
-pa_rpc.cmo: pa_rpc.ml
- $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
+jsonrpc.cmi: jsonrpc.mli rpc.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
.PHONY: install
install: rpc.cmi pa_rpc.cma xmlrpc.cma xmlrpc.cmxa
cp META-xmlrpc META
ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) xmlrpc META xmlrpc.cma xmlrpc.cmxa xmlrpc.cmi rpc.cmi xmlrpc.cmx rpc.cmx xmlrpc.a xmlrpc.o
+ cp META-jsonrpc META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) jsonrpc META jsonrpc.cma jsonrpc.cmxa jsonrpc.cmi rpc.cmi jsonrpc.cmx rpc.cmx jsonrpc.a jsonrpc.o
cp META-rpc-light META
ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) rpc-light META pa_rpc.cma pa_rpc.cmi
rm META
.PHONY: uninstall
uninstall:
ocamlfind remove xmlrpc
+ ocamlfind remove jsonrpc
ocamlfind remove rpc-light
clean:
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ * Author Vincent Hanquez <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
* GNU Lesser General Public License for more details.
*)
-open Rpc
-
let rec list_iter_between f o = function
| [] -> ()
| [h] -> f h
let rec to_fct t f =
match t with
- | Int i -> f (Printf.sprintf "%Ld" i)
- | Bool b -> f (string_of_bool b)
- | Float r -> f (Printf.sprintf "%f" r)
- | String s -> f (escape_string s)
- | Null -> f "null"
- | Enum a ->
+ | Rpc.Int i -> f (Printf.sprintf "%Ld" i)
+ | Rpc.Double r -> f (Printf.sprintf "%f" r)
+ | Rpc.String s -> f (escape_string s)
+ | Rpc.Bool b -> f (string_of_bool b)
+ | Rpc.Nil -> f "null"
+ | Rpc.Array a ->
f "[";
list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a;
f "]";
- | Dict a ->
+ | Rpc.Struct a ->
f "{";
- list_iter_between (fun (k, v) -> to_fct (String k) f; f ": "; to_fct v f)
+ list_iter_between (fun (k, v) -> to_fct (Rpc.String k) f; f ": "; to_fct v f)
(fun () -> f ", ") a;
f "}"
to_buffer t buf;
Buffer.contents buf
-let new_id =
- let count = ref 0L in
- (fun () -> count := Int64.add 1L !count; !count)
-
-let string_of_call call =
- let json = Dict [
- "method", String call.name;
- "params", Enum call.params;
- "id", Int (new_id ());
- ] in
- to_string json
-
-let string_of_response response =
- let json =
- if response.Rpc.success then
- Dict [
- "result", response.Rpc.contents;
- "error", Null;
- "id", Int 0L
- ]
- else
- Dict [
- "result", Null;
- "error", response.Rpc.contents;
- "id", Int 0L
- ] in
- to_string json
+
type error =
| Unexpected_char of int * char * (* json type *) string
| Expect_object_elem_colon
| Expect_comma_or_end
| Expect_object_key
- | Done of t
+ | Done of Rpc.t
type int_value =
- | IObject of (string * t) list
- | IObject_needs_key of (string * t) list
- | IObject_needs_value of (string * t) list * string
- | IArray of t list
+ | IObject of (string * Rpc.t) list
+ | IObject_needs_key of (string * Rpc.t) list
+ | IObject_needs_value of (string * Rpc.t) list * string
+ | IArray of Rpc.t list
type parse_state = {
mutable cursor: cursor;
| _ -> false
let is_valid_unescaped_char c =
- match c with
- | '"' | '\\' | '\b' | '\x0c' | '\n' | '\r' | '\t' -> false
- | _ -> true
+ match (Char.code c) with
+ | 0x22 | 0x5c -> false
+ | x when 0x20 <= x && x <= 0x7f -> true (* only ASCII for now *)
+ | _ -> false
let clist_to_string cs =
let len = List.length cs in
let finish_value s v =
match s.stack, v with
| [], _ -> s.cursor <- Done v
- | IObject_needs_key fields :: tl, String key ->
+ | IObject_needs_key fields :: tl, Rpc.String key ->
s.stack <- IObject_needs_value (fields, key) :: tl;
s.cursor <- Expect_object_elem_colon
| IObject_needs_value (fields, key) :: tl, _ ->
let pop_stack s =
match s.stack with
- | IObject fields :: tl -> s.stack <- tl; finish_value s (Dict (List.rev fields))
- | IArray l :: tl -> s.stack <- tl; finish_value s (Enum (List.rev l))
+ | IObject fields :: tl -> s.stack <- tl; finish_value s (Rpc.Struct (List.rev fields))
+ | IArray l :: tl -> s.stack <- tl; finish_value s (Rpc.Array (List.rev l))
| io :: tl -> raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at pop_stack")
| [] -> raise_internal_error s "empty stack at pop_stack"
let str = tostring_with_leading_zero_check is in
let int = try Int64.of_string str
with Failure _ -> raise_invalid_value s str "int" in
- finish_value s (Int int) in
+ finish_value s (Rpc.Int int) in
let finish_int_exp is es =
let int = tostring_with_leading_zero_check is in
let exp = clist_to_string (List.rev es) in
returning float is more uniform. *)
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Float float) in
+ finish_value s (Rpc.Double float) in
let finish_float is fs =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%s" int frac in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Float float) in
+ finish_value s (Rpc.Double float) in
let finish_float_exp is fs es =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%se%s" int frac exp in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (Float float) in
+ finish_value s (Rpc.Double float) in
match s.cursor with
| Start ->
(match c, rem with
| 'u', 3 -> s.cursor <- In_null 2
| 'l', 2 -> s.cursor <- In_null 1
- | 'l', 1 -> finish_value s Null
+ | 'l', 1 -> finish_value s Rpc.Nil
| _ -> raise_unexpected_char s c "null")
| In_true rem ->
(match c, rem with
| 'r', 3 -> s.cursor <- In_true 2
| 'u', 2 -> s.cursor <- In_true 1
- | 'e', 1 -> finish_value s (Bool true)
+ | 'e', 1 -> finish_value s (Rpc.Bool true)
| _ -> raise_unexpected_char s c "true")
| In_false rem ->
| 'a', 4 -> s.cursor <- In_false 3
| 'l', 3 -> s.cursor <- In_false 2
| 's', 2 -> s.cursor <- In_false 1
- | 'e', 1 -> finish_value s (Bool false)
+ | 'e', 1 -> finish_value s (Rpc.Bool false)
| _ -> raise_unexpected_char s c "false")
| In_int is ->
| In_string cs ->
(match c with
| '\\' -> s.cursor <- In_string_control cs
- | '"' -> finish_value s (String (clist_to_string (List.rev cs)))
+ | '"' -> finish_value s (Rpc.String (clist_to_string (List.rev cs)))
| _ when is_valid_unescaped_char c -> s.cursor <- In_string (c :: cs)
| _ -> raise_unexpected_char s c "string")
| Expect_object_elem_start ->
(match c with
| '"' -> s.stack <- (IObject_needs_key []) :: s.stack; s.cursor <- In_string []
- | '}' -> finish_value s (Dict [])
+ | '}' -> finish_value s (Rpc.Struct [])
| _ when is_space c -> update_line_num s c
| _ -> raise_unexpected_char s c "object_start")
| Done _ -> raise_internal_error s "parse called when parse_state is 'Done'"
type parse_result =
- | Json_value of t * (* number of consumed bytes *) int
+ | Json_value of Rpc.t * (* number of consumed bytes *) int
| Json_parse_incomplete of parse_state
let parse_substring state str ofs len =
end
let of_string = Parser.of_string
-
-exception Malformed_method_request of string
-exception Malformed_method_response of string
-
-let get name dict =
- if List.mem_assoc name dict then
- List.assoc name dict
- else begin
- Printf.eprintf "%s was not found in the dictionnary\n" name;
- let str = List.map (fun (n,_) -> Printf.sprintf "%s=..." n) dict in
- let str = Printf.sprintf "{%s}" (String.concat "," str) in
- raise (Malformed_method_request str)
- end
-
-let call_of_string str =
- match of_string str with
- | Dict d ->
- let name = match get "method" d with String s -> s | _ -> raise (Malformed_method_request str) in
- let params = match get "params" d with Enum l -> l | _ -> raise (Malformed_method_request str) in
- let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_request str) in
- call name params
- | _ -> raise (Malformed_method_request str)
-
-let response_of_string str =
- match of_string str with
- | Dict d ->
- let result = get "result" d in
- let error = get "error" d in
- let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_response str) in
- begin match result, error with
- | Null, Null -> raise (Malformed_method_response str)
- | Null, v -> failure v
- | v, Null -> success v
- | _ -> raise (Malformed_method_response str)
- end
- | _ -> raise (Malformed_method_response str)
-
projects / xcp / xen-api-libs.git / commitdiff