PPX memory interface

_oasis

@@ -105,3 +105,9 @@ Executable example
   Install:            false
   BuildDepends:       lwt, lwt.unix, xcp, rpclib
 
+Executable memory_cli
+  CompiledObject:     best
+  Path:               memory
+  MainIs:             memory_cli.ml
+  Install:            false
+  BuildDepends:       xcp.memory, cmdliner, rpclib.cmdliner, rpclib.markdown

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 602453b3fb6b3d0b87012f531fd91c7d)
+# DO NOT EDIT (digest: c2a2e2072ba30b89a3568ae322ce4992)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -142,24 +142,6 @@ true: annot, bin_annot
 <xen/*.ml{,i,y}>: use_xcp
 # Library xcp_memory
 "memory/xcp_memory.cmxs": use_xcp_memory
-<memory/*.ml{,i,y}>: pkg_cmdliner
-<memory/*.ml{,i,y}>: pkg_cohttp
-<memory/*.ml{,i,y}>: pkg_fd-send-recv
-<memory/*.ml{,i,y}>: pkg_message_switch
-<memory/*.ml{,i,y}>: pkg_message_switch.unix
-<memory/*.ml{,i,y}>: pkg_ppx_deriving_rpc
-<memory/*.ml{,i,y}>: pkg_ppx_sexp_conv
-<memory/*.ml{,i,y}>: pkg_re
-<memory/*.ml{,i,y}>: pkg_rpclib
-<memory/*.ml{,i,y}>: pkg_rpclib.xml
-<memory/*.ml{,i,y}>: pkg_sexplib
-<memory/*.ml{,i,y}>: pkg_threads
-<memory/*.ml{,i,y}>: pkg_unix
-<memory/*.ml{,i,y}>: pkg_uri
-<memory/*.ml{,i,y}>: pkg_xapi-backtrace
-<memory/*.ml{,i,y}>: pkg_xcp-inventory
-<memory/*.ml{,i,y}>: pkg_xmlm
-<memory/*.ml{,i,y}>: use_xcp
 # Library xapi_v6
 "v6/xapi_v6.cmxs": use_xapi_v6
 <v6/*.ml{,i,y}>: pkg_cmdliner
@@ -312,16 +294,57 @@ true: annot, bin_annot
 <example/*.ml{,i,y}>: pkg_xmlm
 <example/*.ml{,i,y}>: use_xcp
 <example/example.{native,byte}>: custom
+# Executable memory_cli
+<memory/memory_cli.{native,byte}>: pkg_cmdliner
+<memory/memory_cli.{native,byte}>: pkg_cohttp
+<memory/memory_cli.{native,byte}>: pkg_fd-send-recv
+<memory/memory_cli.{native,byte}>: pkg_message_switch
+<memory/memory_cli.{native,byte}>: pkg_message_switch.unix
+<memory/memory_cli.{native,byte}>: pkg_ppx_deriving_rpc
+<memory/memory_cli.{native,byte}>: pkg_ppx_sexp_conv
+<memory/memory_cli.{native,byte}>: pkg_re
+<memory/memory_cli.{native,byte}>: pkg_rpclib
+<memory/memory_cli.{native,byte}>: pkg_rpclib.cmdliner
+<memory/memory_cli.{native,byte}>: pkg_rpclib.markdown
+<memory/memory_cli.{native,byte}>: pkg_rpclib.xml
+<memory/memory_cli.{native,byte}>: pkg_sexplib
+<memory/memory_cli.{native,byte}>: pkg_threads
+<memory/memory_cli.{native,byte}>: pkg_unix
+<memory/memory_cli.{native,byte}>: pkg_uri
+<memory/memory_cli.{native,byte}>: pkg_xapi-backtrace
+<memory/memory_cli.{native,byte}>: pkg_xcp-inventory
+<memory/memory_cli.{native,byte}>: pkg_xmlm
+<memory/memory_cli.{native,byte}>: use_xcp
+<memory/memory_cli.{native,byte}>: use_xcp_memory
+<memory/*.ml{,i,y}>: pkg_cmdliner
+<memory/*.ml{,i,y}>: pkg_cohttp
+<memory/*.ml{,i,y}>: pkg_fd-send-recv
+<memory/*.ml{,i,y}>: pkg_message_switch
+<memory/*.ml{,i,y}>: pkg_message_switch.unix
+<memory/*.ml{,i,y}>: pkg_ppx_deriving_rpc
+<memory/*.ml{,i,y}>: pkg_ppx_sexp_conv
+<memory/*.ml{,i,y}>: pkg_re
+<memory/*.ml{,i,y}>: pkg_rpclib
+<memory/*.ml{,i,y}>: pkg_rpclib.cmdliner
+<memory/*.ml{,i,y}>: pkg_rpclib.markdown
+<memory/*.ml{,i,y}>: pkg_rpclib.xml
+<memory/*.ml{,i,y}>: pkg_sexplib
+<memory/*.ml{,i,y}>: pkg_threads
+<memory/*.ml{,i,y}>: pkg_unix
+<memory/*.ml{,i,y}>: pkg_uri
+<memory/*.ml{,i,y}>: pkg_xapi-backtrace
+<memory/*.ml{,i,y}>: pkg_xcp-inventory
+<memory/*.ml{,i,y}>: pkg_xmlm
+<memory/*.ml{,i,y}>: use_xcp
+<memory/*.ml{,i,y}>: use_xcp_memory
 # OASIS_STOP
 <storage/storage_interface.ml{,i}>: syntax_camlp4o
 <xen/xenops_interface.ml{,i}>: syntax_camlp4o
-<memory/memory_interface.ml{,i}>: syntax_camlp4o
 <network/network_interface.ml{,i}>: syntax_camlp4o
 <rrd/rrd_interface.ml{,i}>: syntax_camlp4o
 <v6/v6_interface.ml>: syntax_camlp4o
 <storage/storage_interface.ml>: pkg_rpclib.idl
 <xen/xenops_interface.ml>: pkg_rpclib.idl
-<memory/memory_interface.ml>: pkg_rpclib.idl
 <network/network_interface.ml>: pkg_rpclib.idl
 <rrd/data_source.ml>: pkg_rpclib.idl
 <rrd/rrd_interface.ml>: pkg_rpclib.idl

memory/memory_cli.ml

@@ -0,0 +1,25 @@
+(* Memory CLI *)
+
+open Memory_interface
+open Xcp_client
+open Memory_client
+
+module Cmds = 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 memory API. This allows scripting of the squeeze 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 "memory_cli" ~version:(version_str Cmds.description) ~doc
+
+let cli () =
+  let rpc = Memory_client.rpc in
+  Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
+
+let _ = cli ()

memory/memory_client.ml

@@ -18,10 +18,10 @@ open Xcp_client
 let json_url () = "file:" ^ json_path
 let xml_url () = "file:" ^ xml_path
 
-module Client = Memory_interface.Client(struct
-	let rpc call =
+let rpc call =
 		if !use_switch
 		then json_switch_rpc queue_name call
 		else xml_http_rpc ~srcstr:"xenops" ~dststr:"squeezed" xml_url call
-end)
+
+module Client = Memory_interface.API(Idl.GenClientExnRpc(struct let rpc=rpc end))
 

memory/memory_interface.ml

@@ -14,47 +14,212 @@
 (**
  * @group Memory
  *)
+open Rpc
+open Idl
 
 let service_name = "memory"
 let queue_name = Xcp_service.common_prefix ^ service_name
 let json_path = "/var/xapi/memory.json"
 let xml_path = "/var/xapi/memory"
 
-type reservation_id = string
+type reservation_id =
+  string [@@doc [
+    "The reservation_id is an opaque identifier associated with a block of ";
+    "memory. It is used to reserve memory for a domain before the domain has ";
+    "been created.";
+  ]]
+  [@@deriving rpcty]
 
-exception Cannot_free_this_much_memory of (int64 * int64)
-exception Domains_refused_to_cooperate of (int list)
-exception Unknown_reservation of (reservation_id)
-exception No_reservation
-exception Invalid_memory_value of (int64)
+type domain_zero_policy =
+   | Fixed_size of int64 [@doc ["Never balloon, use the specified fixed size"]]
+   | Auto_balloon of int64 * int64 [@doc ["Balloon between the two sizes specified"]]
+  [@@doc ["Domain zero can have a different policy to that used by guest domains."]]
+  [@@deriving rpcty]
+
+type errors =
+| Cannot_free_this_much_memory of (int64 * int64)
+[@doc [
+  "[Cannot_free_this_much_memory (required, free)] is reported if it is not ";
+  "possible to free [required] kib. [free] is the amount of memory currently free"]]
+| Domains_refused_to_cooperate of (int list)
+[@doc [
+  "[Domains_refused_to_cooperate (domid list)] is reported if a set of domains do ";
+  "not respond in a timely manner to the request to balloon. The uncooperative ";
+  "domain ids are returned."]]
+| Unknown_reservation of (reservation_id)
+[@doc [
+  "[Unknown_reservation (id)] is reported if a the specified reservation_id is ";
+  "unknown."
+]]
+| No_reservation
+[@doc [
+  "[No_reservation] is reported by [query_reservation_of_domain] if the domain ";
+  "does not have a reservation."
+]]
+| Invalid_memory_value of (int64)
+[@doc [
+  "[Invalid_memory_value (value)] is reported if a memory value passed is not ";
+  "valid, e.g. negative."
+]]
+| Unknown_error
+[@doc [
+  "The default variant for forward compatibility."
+]]
+[@@default Unknown_error]
+[@@deriving rpcty]
+
+exception MemoryError of errors
+
+let err = Error.{
+  def = errors;
+  raiser = (function | e -> raise (MemoryError e));
+  matcher = function | MemoryError e -> Some e | _ -> None
+}
 
 type debug_info = string
+[@@doc ["An uninterpreted string associated with the operation."]]
+[@@deriving rpcty]
 
 type session_id = string
-
-external get_diagnostics: debug_info -> string = ""
-
-external login: debug_info -> string -> session_id = ""
-
-external reserve_memory: debug_info -> session_id -> int64 -> reservation_id = ""
-
-external reserve_memory_range: debug_info -> session_id -> int64 -> int64 -> reservation_id * int64 = ""
-
-external delete_reservation: debug_info -> session_id -> reservation_id -> unit = ""
-
-external transfer_reservation_to_domain: debug_info -> session_id -> reservation_id -> int -> unit = ""
-
-external query_reservation_of_domain: debug_info -> session_id -> int -> reservation_id = ""
-
-external balance_memory: debug_info -> unit = ""
-
-external get_host_reserved_memory: debug_info -> int64 = ""
-
-external get_host_initial_free_memory: debug_info -> int64 = ""
-
-type domain_zero_policy =
-   | Fixed_size of int64 (** it will never be ballooned *)
-   | Auto_balloon of int64 * int64 (** it will auto-balloon over a range *)
-
-external get_domain_zero_policy: debug_info -> domain_zero_policy = ""
-
+[@@doc [
+  "An identifier to associate requests with a client. This is ";
+  "obtained by a call to [login]."
+]]
+[@@deriving rpcty]
+
+type reserve_memory_range_result = reservation_id * int64
+[@@deriving rpcty]
+
+module API(R : RPC) = struct
+  open R
+
+  let description = Interface.{
+      name = "Memory";
+      namespace = None;
+      description = [
+        "This interface is used by Xapi and Squeezed to manage the ";
+        "dynamic memory usage of VMs on a host.";
+      ];
+      version=(1,0,0);
+    }
+
+  let implementation = implement description
+
+  (* General parameters, used by more than one API call *)
+
+  let debug_info_p = Param.mk ~description:[
+    "An uninterpreted string to associate with the operation."
+    ] Types.string
+
+  let diagnostics_result_p = Param.mk ~description:[
+    "A string containing diagnostic information from the server."
+    ] Types.string
+
+  let service_name_p = Param.mk ~description:[
+    "The name of the service attempting to interact with the squeeze daemon."
+    ] Types.string
+
+  let session_id_p = Param.mk ~description:[
+    "An identifier to associate requests with a client. This is ";
+    "obtained by a call to [login]."]
+    Types.string
+
+  let domid_p = Param.mk ~description:[
+    "Domain id of a VM."
+    ] Types.int
+
+  let reservation_id_p = Param.mk ~description:[
+    "The reservation_id is the token used to identify a memory allocation."
+    ] reservation_id
+
+  let size_p = Param.mk ~description:[
+    "The size in bytes to reserve"]
+    Types.int64
+
+  let unit_p = Param.mk Types.unit
+
+  (* Individual API calls *)
+
+  let get_diagnostics = declare
+    "get_diagnostics"
+    ["Gets diagnostic information from the server"]
+    (debug_info_p @-> returning diagnostics_result_p err)
+
+  let login = declare
+    "login"
+    ["Logs into the squeeze daemon. Any reservations previously made with the ";
+    "specified service name not yet associated with a domain will be removed."]
+    (debug_info_p @-> service_name_p @-> returning session_id_p err)
+
+
+  let reserve_memory = declare
+    "reserve_memory"
+    ["[reserve_memory dbg session size] reserves memory for a domain. If necessary, ";
+     "other domains will be ballooned down to ensure [size] is available. The call ";
+     "returns a reservation_id that can later be transferred to a domain."]
+    (debug_info_p @-> session_id_p @-> size_p @-> returning reservation_id_p err)
+
+  let reserve_memory_range =
+    let result = Param.mk
+      ~description:[
+        "A tuple containing the reservation_id and the amount of memory actually reserved."
+      ]
+      reserve_memory_range_result
+    in
+    declare
+      "reserve_memory_range"
+     ["[reserve_memory_range dbg session min max] reserves memory for a domain. If necessary, ";
+      "other domains will be ballooned down to ensure enough memory is available. The amount ";
+      "of memory will be between [min] and [max] according to the policy in operation. The call ";
+      "returns a reservation_id and the actual memory amount that can later be transferred to a domain."]
+    (debug_info_p @-> session_id_p @-> size_p @-> size_p @-> returning result err)
+
+
+  let delete_reservation =
+    declare
+    "delete_reservation"
+    ["Deletes a reservation. Note that memory rebalancing is not done synchronously after the ";
+     "operation has completed."]
+    (debug_info_p @-> session_id_p @-> reservation_id_p @-> returning unit_p err)
+
+  let transfer_reservation_to_domain =
+    declare
+    "transfer_reservation_to_domain"
+    ["Transfers a reservation to a domain. This is called when the domain has been created for ";
+     "the VM for which the reservation was initially made."]
+    (debug_info_p @-> session_id_p @-> reservation_id_p @-> domid_p @-> returning unit_p err)
+
+  let query_reservation_of_domain =
+    declare
+    "query_reservation_of_domain"
+    ["Queries the reservation_id associated with a domain"]
+    (debug_info_p @-> session_id_p @-> domid_p @-> returning reservation_id_p err)
+
+  let balance_memory =
+    declare
+    "balance_memory"
+    ["Forces a rebalance of the hosts memory. Blocks until the system is in a stable ";
+    "state."]
+    (debug_info_p @-> returning unit_p err)
+
+  let get_host_reserved_memory =
+    declare
+    "get_host_reserved_memory"
+    ["Gets the amount of reserved memory in a host. This is the lower limit of memory that ";
+     "squeezed will ensure remains unused by any domain or reservation."]
+    (debug_info_p @-> returning size_p err)
+
+  let get_host_initial_free_memory =
+    declare
+    "get_host_initial_free_memory"
+    ["Gets the amount of initial free memory in a host"]
+    (debug_info_p @-> returning size_p err)
+
+  let get_domain_zero_policy =
+    let result_p = Param.mk ~description:["The policy associated with domain 0"] domain_zero_policy in
+    declare
+    "get_domain_zero_policy"
+    ["Gets the ballooning policy for domain zero."]
+    (debug_info_p @-> returning result_p err)
+
+end