../../util/util_inventory \
../../util/version \
../../xapi/xapi_inventory \
- ../../license/v6xmlrpc \
+ ../../license/v6rpc \
../../license/v6daemon \
$(COMMON_OBJS) \
$(CLIENT_OBJS)
-OCAML_LIBS = ../util/version ../idl/ocaml_backend/common ../idl/ocaml_backend/client
+OCAML_LIBS = ../util/version ../idl/ocaml_backend/xapi_client
OCAMLINCLUDES = ../idl/ocaml_backend ../idl ../autogen ../xapi ../gpg ../util
-OCAMLPACKS = xml-light2 stdext stunnel http-svr log
+OCAMLPACKS = xml-light2 stdext stunnel http-svr log rpc-light
-IEXE=install -m 755 -o root -g root
+UseCamlp4(rpc-light.syntax, v6rpc)
V6FILES = \
fakev6 \
- v6xmlrpc \
+ v6rpc \
v6daemon
# Name of daemon to install in dom0:
* GNU Lesser General Public License for more details.
*)
+open V6rpc
module D=Debug.Debugger(struct let name="v6client" end)
open D
let socket = "/var/xapi/v6"
(* RPC function for communication with the v6 daemon *)
-let v6rpc xml = Xmlrpcclient.do_xml_rpc_unix ~version:"1.0" ~filename:socket ~path:"/" xml
+let v6rpc call = Rpc_client.do_rpc_unix ~version:"1.0" ~filename:socket ~path:"/" call
(* conversion to v6 edition codes *)
let editions = [Edition.Free, "FREE"]
if !connected then begin
debug "release license";
try
- let request = XMLRPC.To.methodCall "shutdown" [] in
- let response = v6rpc request in
- debug "response: %s" (Xml.to_string response);
- match XMLRPC.From.methodResponse response with
- | XMLRPC.Success [r] ->
- let success = XMLRPC.From.boolean r in
- debug "success: %b" success;
- if success then begin
- match !licensed with
+ let success =
+ let call = Rpc.call "shutdown" [] in
+ let response = v6rpc call in
+ try Rpc.bool_of_rpc response.Rpc.contents
+ with e ->
+ error "Got error %s" (Printexc.to_string e);
+ raise V6DaemonFailure in
+ debug "success: %b" success;
+ if success then begin
+ match !licensed with
| None -> ()
| Some edition ->
info "Checked %s license back in to license server." (Edition.to_string edition);
reset_state ()
end
- | _ ->
+ else
raise V6DaemonFailure
with
| Unix.Unix_error(a, b, c) ->
debug "invalid edition!"
else begin
try
- let myassoc key args =
- try List.assoc key args
- with Not_found ->
- error "key %s not found in v6d's response" key;
- raise V6DaemonFailure
- in
- let get_named_string name args = XMLRPC.From.string (myassoc name args) in
- let get_named_int name args = XMLRPC.From.int (myassoc name args) in
- let v6_edition = List.assoc edition editions in
- let fields = ["address", XMLRPC.To.string address; "port", XMLRPC.To.int (Int32.of_int port); "edition", XMLRPC.To.string v6_edition] in
- let params = XMLRPC.To.structure fields in
- let request = XMLRPC.To.methodCall "initialise" [params] in
- let response = v6rpc request in
- debug "response: %s" (Xml.to_string response);
- match XMLRPC.From.methodResponse response with
- | XMLRPC.Success [r] ->
- let str = XMLRPC.From.structure r in
- let license = get_named_string "license" str in
- let days_to_expire = Int32.to_int (get_named_int "days_to_expire" str) in
- debug "license: %s; days-to-expire: %d" license days_to_expire;
- connected := true;
- (* set expiry date *)
- let now = Unix.time () in
- if days_to_expire > -1 then
- expires := now +. (float_of_int (days_to_expire * 24 * 3600))
+ let edition' = List.assoc edition editions in
+ let params = rpc_of_initialise_in { address = address; port = port; edition = edition' } in
+ let call = Rpc.call "initialise" [ params ] in
+ let response = v6rpc call in
+ debug "response: %s" (Rpc.to_string response.Rpc.contents);
+ let license, days_to_expire =
+ if response.Rpc.success then
+ let r = initialise_out_of_rpc response.Rpc.contents in r.license, r.days_to_expire
else
- expires := never;
- (* check fist point *)
- (* CA-33155: FIST point may only set an expiry date earlier than the actual one *)
- begin match Xapi_fist.set_expiry_date () with
+ raise V6DaemonFailure in
+ debug "license: %s; days-to-expire: %ld" license days_to_expire;
+ connected := true;
+ (* set expiry date *)
+ let now = Unix.time () in
+ if days_to_expire > -1l then
+ expires := now +. (Int32.to_float days_to_expire *. 24. *. 3600.)
+ else
+ expires := never;
+ (* check fist point *)
+ (* CA-33155: FIST point may only set an expiry date earlier than the actual one *)
+ begin match Xapi_fist.set_expiry_date () with
| None -> ()
| Some d ->
let fist_date = Date.to_float (Date.of_string d) in
if fist_date < !expires then expires := fist_date
- end;
- (* check return status *)
- if license = "real" then begin
- info "Checked out %s license from license server." (Edition.to_string edition);
- licensed := Some edition;
- grace := false
- end else if license = "grace" then begin
- info "Obtained %s grace license." (Edition.to_string edition);
- licensed := Some edition;
- grace := true;
- if Xapi_fist.reduce_grace_period () then
- expires := now +. (15. *. 60.)
- end else begin
- info "License check out failed.";
- licensed := None;
- grace := false
- end
- | _ ->
- raise V6DaemonFailure
+ end;
+ (* check return status *)
+ if license = "real" then begin
+ info "Checked out %s license from license server." (Edition.to_string edition);
+ licensed := Some edition;
+ grace := false
+ end else if license = "grace" then begin
+ info "Obtained %s grace license." (Edition.to_string edition);
+ licensed := Some edition;
+ grace := true;
+ if Xapi_fist.reduce_grace_period () then
+ expires := now +. (15. *. 60.)
+ end else begin
+ info "License check out failed.";
+ licensed := None;
+ grace := false
+ end
with
| Unix.Unix_error(a, b, c) ->
error "Problem while initialising (%s): %s" b (Unix.error_message a);
try
let ls = Db.Host.get_license_server ~__context ~self:host in
let address = List.assoc "address" ls in
- let port = int_of_string (List.assoc "port" ls) in
- debug "obtaining %s v6 license; license server address: %s; port: %d" (Edition.to_string edition) address port;
+ let port = Int32.of_string (List.assoc "port" ls) in
+ debug "obtaining %s v6 license; license server address: %s; port: %ld" (Edition.to_string edition) address port;
(* obtain v6 license *)
connect_and_get_license edition address port
with
let body = Http_svr.read_body req bio in
debug "Request: %s" body;
let s = Buf_io.fd_of bio in
- let xml = Xml.parse_string body in
- let result = process xml in
- let str = Xml.to_string result in
+ let rpc = Xmlrpc.call_of_string body in
+ let result = process rpc in
+ let str = Xmlrpc.string_of_response result in
debug "Response: %s" str;
Http_svr.response_str req s str
(** Licensing daemon creation module *)
(** Create and start up the licensing daemon *)
-val startup : (unit -> 'a) -> (Xml.xml -> Xml.xml) -> unit
+val startup : (unit -> 'a) -> (Rpc.call -> Rpc.response) -> unit
--- /dev/null
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+module D = Debug.Debugger(struct let name="v6xmlrpc" end)
+open D
+
+exception Unmarshalling_error of string
+
+type initialise_in = {
+ address: string;
+ port: int32;
+ edition: string;
+} with rpc
+
+type initialise_out = {
+ license: string;
+ days_to_expire: int32;
+} with rpc
+
+type failure = string * (string list) with rpc
+let response_of_failure code params =
+ Rpc.failure (rpc_of_failure (code, params))
+let response_of_fault code =
+ Rpc.failure (rpc_of_failure ("Fault", [code]))
+
+module type V6api = sig
+ val initialise : string -> int32 -> string -> string * int32
+ val shutdown : unit -> bool
+ val reopen_logs : unit -> bool
+end
+
+module V6process = functor(V: V6api) -> struct
+ let process call =
+ let response =
+ try match call.Rpc.name with
+ | "initialise" ->
+ let arg_rpc = match call.Rpc.params with [a] -> a | _ -> raise (Unmarshalling_error "initialise") in
+ let arg = initialise_in_of_rpc arg_rpc in
+ let l,d = V.initialise arg.address arg.port arg.edition in
+ let response = rpc_of_initialise_out { license = l; days_to_expire = d } in
+ Rpc.success response
+ | "shutdown" ->
+ let response = Rpc.rpc_of_bool (V.shutdown ()) in
+ Rpc.success response
+ | "reopen-logs" ->
+ let response = Rpc.rpc_of_bool (V.reopen_logs ()) in
+ Rpc.success response
+ | x -> response_of_fault ("unknown RPC: " ^ x)
+ with e ->
+ log_backtrace ();
+ response_of_failure "INTERNAL_ERROR" [Printexc.to_string e] in
+ response
+end
+
--- /dev/null
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** XML/RPC handler for the licensing daemon *)
+
+(** The XML/RPC interface of the licensing daemon *)
+module type V6api =
+ sig
+ val initialise : string -> int32 -> string -> string * int32
+ val shutdown : unit -> bool
+ val reopen_logs : unit -> bool
+ end
+
+(** XML/RPC handler *)
+module V6process : functor (V : V6api) ->
+ sig
+ (** Process an XML/RPC call *)
+ val process : Rpc.call -> Rpc.response
+ end
+
+(** {2 Marshaling functions} *)
+
+type initialise_in = {
+ address: string;
+ port: int32;
+ edition: string;
+}
+
+val rpc_of_initialise_in : initialise_in -> Rpc.t
+
+type initialise_out = {
+ license: string;
+ days_to_expire: int32;
+}
+
+val initialise_out_of_rpc : Rpc.t -> initialise_out
* GNU Lesser General Public License for more details.
*)
-module P = V6xmlrpc.V6process(Fakev6)
+module P = V6rpc.V6process(Fakev6)
let _ =
Logs.reset_all [ "file:/var/log/v6d.log" ];
(** Instatiate licensing daemon XML/RPC handler *)
module P : sig
(** Process an XML/RPC call *)
- val process : XMLRPC.xmlrpc -> XMLRPC.xmlrpc
+ val process : Rpc.call -> Rpc.response
end
+++ /dev/null
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-module D = Debug.Debugger(struct let name="v6xmlrpc" end)
-open D
-
-exception Unmarshalling_error of string
-
-module type V6api = sig
- val initialise : string -> int32 -> string -> string * int32
- val shutdown : unit -> bool
- val reopen_logs : unit -> bool
-end
-
-module V6process = functor(V: V6api) -> struct
- let myassoc key args =
- try List.assoc key args with Not_found -> raise (Unmarshalling_error key)
-
- let get_named_string name args =
- XMLRPC.From.string (myassoc name args)
-
- let get_named_int name args =
- XMLRPC.From.int (myassoc name args)
-
- let process xml =
- let call,args = XMLRPC.From.methodCall xml in
- let args = try XMLRPC.From.structure (List.hd args) with _ -> [] in
- let response =
- try match call with
- | "initialise" ->
- let address = get_named_string "address" args in
- let port = get_named_int "port" args in
- let edition = get_named_string "edition" args in
- let response = match (V.initialise address port edition) with
- | l, d -> XMLRPC.To.structure
- ["license", XMLRPC.To.string l; "days_to_expire", XMLRPC.To.int d] in
- XMLRPC.Success [response]
- | "shutdown" ->
- let response = XMLRPC.To.boolean (V.shutdown ()) in
- XMLRPC.Success [response]
- | "reopen-logs" ->
- let response = XMLRPC.To.boolean (V.reopen_logs ()) in
- XMLRPC.Success [response]
- | x -> XMLRPC.Fault (Int32.of_int 0, "unknown RPC: " ^ x)
- with e ->
- log_backtrace ();
- XMLRPC.Failure ("INTERNAL_ERROR",[Printexc.to_string e])
- in
- XMLRPC.To.methodResponse response
-end
-
+++ /dev/null
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-(** XML/RPC handler for the licensing daemon *)
-
-(** The XML/RPC interface of the licensing daemon *)
-module type V6api =
- sig
- val initialise : string -> int32 -> string -> string * int32
- val shutdown : unit -> bool
- val reopen_logs : unit -> bool
- end
-
-(** XML/RPC handler *)
-module V6process : functor (V : V6api) ->
- sig
- (** Process an XML/RPC call *)
- val process : XMLRPC.xmlrpc -> XMLRPC.xmlrpc
- end
../database/db_hiupgrade \
certificates \
../license/v6client \
+ ../license/v6rpc \
bios_strings \
xapi_config \
../license/grace_retry \
projects / xcp / xen-api.git / commitdiff