CP-26098: Port v6d interface from Camlp4 to PPX

v6/jbuild

@@ -15,8 +15,8 @@ let flags = function
     in
     go ic ""
 
-let rewriters_camlp4 = ["rpclib.idl -syntax camlp4o"]
 let rewriters_ppx = ["ppx_deriving_rpc"; "ppx_sexp_conv"]
+let flags = flags rewriters_ppx
 
 let coverage_rewriter =
   let is_coverage = try Unix.getenv "BISECT_ENABLE" = "YES" with Not_found -> false in
@@ -29,27 +29,13 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {|
 (jbuild_version 1)
 
 (library
- ((name xapi_v6_interface)
-  (public_name xcp.v6.interface)
-  (modules (v6_interface))
-  (flags (:standard -w -39 %s))
-  (libraries
-   (rpclib
-    threads
-    xcp))
-  (wrapped false)
-  %s))
-
-(library
- ((name xapi_v6)
+ ((name xcp_v6)
   (public_name xcp.v6)
-  (modules (:standard \ v6_interface))
   (flags (:standard -w -39 %s))
   (libraries
    (rpclib
     threads
-    xapi_v6_interface
     xcp))
   (wrapped false)
   %s))
-|} (flags rewriters_camlp4) coverage_rewriter (flags rewriters_ppx) coverage_rewriter
+|} flags coverage_rewriter

v6/v6_cli.ml

@@ -0,0 +1,21 @@
+(* Licensing CLI *)
+
+module Cmds =V6_interface.RPC_API(Cmdlinergen.Gen ())
+
+let version_str description =
+  let maj,min,mic = description.Idl.Interface.version in
+  Printf.sprintf "%d.%d.%d" maj min mic
+
+let default_cmd =
+  let doc = String.concat "" [
+    "A CLI for the V6d API. This allows scripting of the licensing daemon ";
+    "for testing and debugging. This tool is not intended to be used as an ";
+    "end user tool"] in
+  Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())),
+  Cmdliner.Term.info "licensing_cli" ~version:(version_str Cmds.description) ~doc
+
+let cli () =
+  let rpc = V6_client.rpc in
+  Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
+
+let _ = cli ()

v6/v6_client.ml

@@ -25,21 +25,18 @@ let retry_econnrefused f =
 				None in
 		match result with
 		| Some x -> x
-		| None -> if retry then loop false else raise V6d_failure
+		| None -> if retry then loop false else raise (V6_error V6d_failure)
 	in
 	loop true
 
-module Client = V6_interface.Client(struct
-	let rpc call =
-		retry_econnrefused (fun () ->
-			if !use_switch
-			then json_switch_rpc !queue_name call
-			else xml_http_rpc
-				~srcstr:(Xcp_client.get_user_agent ())
-				~dststr:"v6"
-				V6_interface.uri
-				call
-		)
-end)
 
+let json_url () = "file:" ^ json_path
+let xml_url () = "file:" ^ xml_path
+
+let rpc call =
+		if !use_switch
+		then json_switch_rpc !queue_name call
+		else xml_http_rpc ~srcstr:"xapi" ~dststr:"v6d" xml_url call
+
+module Client = V6_interface.RPC_API(Idl.GenClientExnRpc(struct let rpc=rpc end))
 include Client

v6/v6_interface.ml

@@ -12,33 +12,137 @@
  * GNU Lesser General Public License for more details.
  *)
 
+(**
+   @group Licensing
+*)
+open Rpc
+open Idl
+
 let service_name = "v6d"
 let queue_name = ref (Xcp_service.common_prefix ^ service_name)
 let default_sockets_dir = "/var/lib/xcp"
 let default_path = ref (Filename.concat default_sockets_dir service_name)
 let uri () = "file:" ^ !default_path
+let json_path = "/var/xapi/v6.json"
+let xml_path = "/var/xapi/v6"
 
+(** Uninterpreted/sanitised string associated with operation *)
 type debug_info = string
+[@@deriving rpcty]
+
+(** Record representing software edition *)
+type edition =
+  {
+    title : string ;
+    (** Name of edition, this will be passed to apply_edition *)
+    official_title : string ;
+    (** Marketing title used to advertise edition *)
+    code : string ;
+    (** Abbreviated form of name, used to show up in logs and on command line *)
+    order : int ;
+    (** Number indicating ordering among other editions;
+        low numbers correspond to fewer features, and vice versa *)
+  }
+[@@deriving rpcty]
 
-type edition_info = {
-    edition: string;
+(** List of edition records *)
+type edition_list = edition list
+[@@deriving rpcty]
+
+(** Record of edition info, including xapi parameters and features *)
+type edition_info =
+  {
+    edition_name: string;
+    (** Name of edition *)
     xapi_params: (string * string) list;
+    (** List of parameters used by Xapi *)
     additional_params: (string * string) list;
+    (** Addition parameters supplied *)
     experimental_features: (string * bool) list;
-}
+    (** List of experimental features and whether they're available in this edition *)
+  }
+[@@deriving rpcty]
+
+(** [string * string] list *)
+type string_pair_lst = (string * string) list
+[@@deriving rpcty]
+
+(** Wrapper for specific errors in managing features *)
+type errors =
+  | Invalid_edition of string
+  (** Thrown by apply_edition on receiving unfamiliar edition.
+   *  Note: get_editions returns list of all valid editions *)
+  | License_expired
+  (** Thrown by license_check when expiry date matches or precedes current date *)
+  | License_processing_error
+  (** License could not be processed *)
+  | License_checkout_error of string
+  (** License could not be checked out *)
+  | Missing_connection_details
+  (** Thrown if connection port or address parameter not supplied to check_license *)
+  | V6d_failure
+  (** Daemon failed to enable features *)
+[@@default V6d_failure]
+[@@deriving rpcty]
+
+(** Pass error variant as exn for error handler *)
+exception V6_error of errors
+[@@deriving rpcty]
+
+(** handle exception generation and raising *)
+let err = Error.{
+    def = errors;
+    raiser = (function
+        | e -> raise (V6_error e));
+    matcher = (function
+      | V6_error e -> Some e
+      | _ -> None)
+  }
+
+
+(** functor to autogenerate code using PPX *)
+module RPC_API(R : RPC) = struct
+  open R
+
+  (* description of V6d interface module *)
+  let description = Interface.{
+      name = "Licensing";
+      namespace = None;
+      description =
+        [
+          "This interface is used by Xapi and V6d to manage "
+        ; "enabling and disabling features."
+        ];
+      version=(1,0,0);        }
+
+  (* define implementation *)
+  let implementation = implement description
+
+  (* define general parameters for API calls *)
+  let debug_info_p = Param.mk ~description:[
+      "An uninterpreted string to associate with the operation."
+    ] debug_info
+
+  (* ---- API call definitions ---- *)
 
-exception Invalid_edition of string
-exception V6d_failure
-exception License_expired
-exception License_processing_error
-exception Missing_connection_details
-exception License_checkout_error of string
+  let apply_edition =
+    let edition_p = Param.mk ~description:["Edition title"] Types.string in
+    let edition_info_p = Param.mk ~description:["Edition info"] edition_info in
+    let current_params_p = Param.mk ~description:["Xapi parameters"] string_pair_lst in
+    declare "apply_edition"
+      ["Checks license info to ensures enabled features are compatible."]
+      ( debug_info_p @-> edition_p @-> current_params_p @-> returning edition_info_p err )
 
-(* dbg_str -> requested edition -> current params -> edition_info *)
-external apply_edition : debug_info -> string -> (string * string) list -> edition_info = ""
+  let get_editions =
+    let edition_list_p = Param.mk ~description:["List of editions"] edition_list in
+    declare "get_editions"
+      ["Gets list of accepted editions."]
+      ( debug_info_p @-> returning edition_list_p err )
 
-(* dbg_str -> list of editions *)
-external get_editions : debug_info -> (string * (string * string * int)) list = ""
+  let get_version =
+    let result_p = Param.mk ~description:["String of version."] Types.string in
+    declare "get_version"
+      ["Returns version"]
+      ( debug_info_p @-> returning result_p err )
 
-(* dbg_str -> result *)
-external get_version : debug_info -> string = ""
+end