Skip to content

Commit

Permalink
Merge pull request #163 from jonludlam/ppx2
Browse files Browse the repository at this point in the history 
PPX memory interface
  • Loading branch information
@mseri
mseri committed Jul 12, 2017
2 parents 2d55a0e + 0c8c773 commit 48dc1c4
Show file tree
Hide file tree
Showing 7 changed files with 447 additions and 104 deletions.
6 changes: 6 additions & 0 deletions _oasis
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
65 changes: 44 additions & 21 deletions _tags
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
25 changes: 25 additions & 0 deletions memory/memory_cli.ml
View file
Original file line number Diff line number Diff line change
@@ -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 ()
6 changes: 3 additions & 3 deletions memory/memory_client.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))

231 changes: 198 additions & 33 deletions memory/memory_interface.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Loading

0 comments on commit 48dc1c4

Please sign in to comment.