/* Define to 1 if you have the `virConnectGetURI' function. */
#undef HAVE_VIRCONNECTGETURI
+/* Define to 1 if you have the `virConnectListAllDomains' function. */
+#undef HAVE_VIRCONNECTLISTALLDOMAINS
+
/* Define to 1 if you have the `virConnectListDefinedStoragePools' function.
*/
#undef HAVE_VIRCONNECTLISTDEFINEDSTORAGEPOOLS
virStorageVolGetPath \
virDomainBlockPeek \
virDomainMemoryPeek \
+ virConnectListAllDomains \
])
# This jobs API was never published and is due to get overhauled
let conn = C.connect_readonly ?name () in
(* List running domains. *)
- let n = C.num_of_domains conn in
- let ids = C.list_domains conn n in
- let domains = Array.map (D.lookup_by_id conn) ids in
- Array.iter (
+ let domains =
+ fst (Libvirt.get_domains conn ~want_info:false [D.ListActive]) in
+ List.iter (
fun dom ->
printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom)
) domains;
(* List inactive domains. *)
- let n = C.num_of_defined_domains conn in
- let names = C.list_defined_domains conn n in
- Array.iter (
- fun name ->
- printf "inactive %s\n%!" name
- ) names;
+ let domains =
+ fst (Libvirt.get_domains conn ~want_info:false [D.ListInactive]) in
+ List.iter (
+ fun dom ->
+ printf "inactive %s\n%!" (D.get_name dom)
+ ) domains;
with
Libvirt.Virterror err ->
eprintf "error: %s\n" (Libvirt.Virterror.to_string err)
threads : int;
}
+ type list_flag =
+ | ListNoState | ListRunning | ListBlocked
+ | ListPaused | ListShutdown | ListShutoff | ListCrashed
+ | ListActive
+ | ListInactive
+ | ListAll
+
external connect : ?name:string -> unit -> rw t = "ocaml_libvirt_connect_open"
external connect_readonly : ?name:string -> unit -> ro t = "ocaml_libvirt_connect_open_readonly"
external close : [>`R] t -> unit = "ocaml_libvirt_connect_close"
type memory_flag = Virtual
+ type list_flag =
+ | ListNoState | ListRunning | ListBlocked
+ | ListPaused | ListShutdown | ListShutoff | ListCrashed
+ | ListActive
+ | ListInactive
+ | ListAll
+
type block_stats = {
rd_req : int64;
rd_bytes : int64;
*)
let max_peek _ = 65536
+ external list_all_domains : 'a Connect.t -> ?want_info:bool -> list_flag list -> 'a t array * info array = "ocaml_libvirt_connect_list_all_domains"
+
external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux"
external create_linux_job : [>`W] Connect.t -> xml -> ([`Domain], rw) job_t = "ocaml_libvirt_domain_create_linux_job"
external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id"
exception Virterror of Virterror.t
exception Not_supported of string
+let rec map_ignore_errors f = function
+ | [] -> []
+ | x :: xs ->
+ try f x :: map_ignore_errors f xs
+ with Virterror _ -> map_ignore_errors f xs
+
+(* First time we are called, we will check if
+ * virConnectListAllDomains is supported.
+ *)
+let have_list_all_domains = ref None
+
+let get_domains conn ?(want_info = true) flags =
+ let have_list_all_domains =
+ match !have_list_all_domains with
+ | Some v -> v
+ | None ->
+ (* Check if virConnectListAllDomains is supported
+ * by this version of libvirt.
+ *)
+ let v =
+ (* libvirt has a short-cut which makes this very quick ... *)
+ try ignore (Domain.list_all_domains conn []); true
+ with Not_supported "virConnectListAllDomains" -> false in
+ have_list_all_domains := Some v;
+ v in
+
+ if have_list_all_domains then (
+ (* Good, we can use the shiny new method. *)
+ let doms, infos = Domain.list_all_domains conn ~want_info flags in
+ Array.to_list doms, Array.to_list infos
+ )
+ else (
+ (* Old/slow/inefficient method. *)
+ let get_all, get_active, get_inactive, another_flag =
+ let rec loop ((all, active, inactive, another) as xs) = function
+ | [] -> xs
+ | Domain.ListAll :: _ -> (true, true, true, false)
+ | Domain.ListActive :: fs -> loop (all, true, inactive, another) fs
+ | Domain.ListInactive :: fs -> loop (all, active, true, another) fs
+ | _ -> (true, true, true, true)
+ in
+ loop (false, false, false, false) flags in
+
+ let active_doms =
+ if get_active then (
+ let n = Connect.num_of_domains conn in
+ let ids = Connect.list_domains conn n in
+ let ids = Array.to_list ids in
+ map_ignore_errors (Domain.lookup_by_id conn) ids
+ ) else [] in
+
+ let inactive_doms =
+ if get_inactive then (
+ let n = Connect.num_of_defined_domains conn in
+ let names = Connect.list_defined_domains conn n in
+ let names = Array.to_list names in
+ map_ignore_errors (Domain.lookup_by_name conn) names
+ ) else [] in
+
+ let doms = active_doms @ inactive_doms in
+
+ if not another_flag then (
+ if want_info then
+ List.split (
+ map_ignore_errors (fun dom -> (dom, Domain.get_info dom)) doms
+ )
+ else
+ doms, []
+ ) else (
+ (* Slow method: We have to get the infos and filter on state. *)
+ let flag_is_set =
+ let h = Hashtbl.create 13 in
+ List.iter (fun flag -> Hashtbl.add h flag ()) flags;
+ Hashtbl.mem h
+ in
+
+ let doms =
+ map_ignore_errors (fun dom -> (dom, Domain.get_info dom)) doms in
+ let doms = List.filter (
+ fun (dom, { Domain.state = state }) ->
+ match state with
+ | Domain.InfoNoState -> flag_is_set Domain.ListNoState
+ | Domain.InfoRunning ->
+ flag_is_set Domain.ListActive || flag_is_set Domain.ListRunning
+ | Domain.InfoBlocked ->
+ flag_is_set Domain.ListActive || flag_is_set Domain.ListBlocked
+ | Domain.InfoPaused ->
+ flag_is_set Domain.ListActive || flag_is_set Domain.ListPaused
+ | Domain.InfoShutdown ->
+ flag_is_set Domain.ListActive || flag_is_set Domain.ListShutdown
+ | Domain.InfoShutoff ->
+ flag_is_set Domain.ListInactive
+ || flag_is_set Domain.ListShutoff
+ | Domain.InfoCrashed -> flag_is_set Domain.ListCrashed
+ ) doms in
+ List.split doms
+ )
+ )
+
(* Initialization. *)
external c_init : unit -> unit = "ocaml_libvirt_init"
let () =
{{:http://libvirt.org/html/libvirt-libvirt.html}virConnect*, virDomain* and virNetwork* functions from libvirt}.
For brevity I usually rename these modules like this:
-{v
+{[
module C = Libvirt.Connect
module D = Libvirt.Domain
module N = Libvirt.Network
-v}
+]}
To get a connection handle, assuming a Xen hypervisor:
-{v
+{[
let name = "xen:///"
let conn = C.connect_readonly ~name ()
-v}
+]}
{3 Example: List running domains}
-{v
+{[
open Printf
-let n = C.num_of_domains conn in
-let ids = C.list_domains conn n in
-let domains = Array.map (D.lookup_by_id conn) ids in
-Array.iter (
+let domains =
+ fst (Libvirt.get_domains conn ~want_info:false [D.ListActive]) in
+List.iter (
fun dom ->
printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom)
) domains;
-v}
+]}
{3 Example: List inactive domains}
-{v
-let n = C.num_of_defined_domains conn in
-let names = C.list_defined_domains conn n in
-Array.iter (
- fun name ->
- printf "inactive %s\n%!" name
-) names;
-v}
+{[
+let domains =
+ fst (Libvirt.get_domains conn ~want_info:false [D.ListInactive]) in
+List.iter (
+ fun dom ->
+ printf "inactive %s\n%!" (D.get_name dom)
+) domains;
+]}
{3 Example: Print node info}
-{v
+{[
let node_info = C.get_node_info conn in
printf "model = %s\n" node_info.C.model;
printf "memory = %Ld K\n" node_info.C.memory;
let uri = C.get_uri conn in
printf "uri = %s\n%!" uri
-v}
+]}
*)
Note that even though you hold open (eg) a domain object, that
doesn't mean that the domain (virtual machine) actually exists.
The domain could have been shut down or deleted by another user.
- Thus domain objects can through odd exceptions at any time.
+ Thus domain objects can raise odd exceptions at any time.
This is just the nature of virtualisation.
{3 Backwards and forwards compatibility}
We don't support libvirt < 0.2.1, and never will so don't ask us.
+ {3 Get list of domains}
+
+ This is a very common operation, and libvirt supports various
+ different methods to do it. We have hidden the complexity in a
+ flexible {!Libvirt.get_domains} call which is easy to use and
+ automatically chooses the most efficient method depending on the
+ version of libvirt in use.
+
{3 Threads}
You can issue multiple concurrent libvirt requests in
If you want to handle both read-write and read-only
connections at runtime, use a variant similar to this:
-{v
+{[
type conn_t =
| No_connection
| Read_only of Libvirt.ro Libvirt.Connect.t
| Read_write of Libvirt.rw Libvirt.Connect.t
-v}
+]}
See also the source of [mlvirsh].
*)
+(** {3 Forward definitions}
+
+ These definitions are placed here to avoid the need to
+ use recursive module dependencies.
+*)
+
type ('a, 'b) job_t
-(** Forward definition of {!Job.t} to avoid recursive module dependencies. *)
+(** Forward definition of {!Job.t}. *)
(** {3 Connections} *)
val list_domains : [>`R] t -> int -> int array
(** [list_domains conn max] returns the running domain IDs,
up to a maximum of [max] entries.
+
Call {!num_of_domains} first to get a value for [max].
+
+ See also: {!Libvirt.get_domains}.
*)
val num_of_domains : [>`R] t -> int
(** Returns the number of running domains. *)
(** [list_defined_domains conn max]
returns the names of the inactive domains, up to
a maximum of [max] entries.
+
Call {!num_of_defined_domains} first to get a value for [max].
+
+ See also: {!Libvirt.get_domains}.
*)
val num_of_networks : [>`R] t -> int
(** Returns the number of networks. *)
| InfoShutdown | InfoShutoff | InfoCrashed
type info = {
- state : state; (** running state *)
+ state : state; (** running state *)
max_mem : int64; (** maximum memory in kilobytes *)
memory : int64; (** memory used in kilobytes *)
nr_virt_cpu : int; (** number of virtual CPUs *)
type memory_flag = Virtual
+ type list_flag =
+ | ListNoState | ListRunning | ListBlocked
+ | ListPaused | ListShutdown | ListShutoff | ListCrashed
+ | ListActive
+ | ListInactive
+ | ListAll
+
type block_stats = {
rd_req : int64;
rd_bytes : int64;
functions. If you want to peek more than this then you must
break your request into chunks. *)
+ val list_all_domains : 'a Connect.t -> ?want_info:bool -> list_flag list -> 'a t array * info array
+ (** [list_all_domains conn flags] returns all domains which
+ match [flags].
+
+ This can return both active and inactive domains. The
+ list of flags controls what domains are returned. See
+ {!list_flag}.
+
+ The two arrays returned will have the same length, unless
+ [~want_info] is [false] in which case the info array
+ will be zero-length. The default for [~want_info] is [true].
+ In most cases there is no extra penalty for getting the
+ info fields, or the penalty is insignificant.
+
+ This call was introduced in libvirt 0.4.5. Because you
+ might dynamically link to an older version of libvirt which
+ doesn't have this call, you should use {!Libvirt.get_domains}
+ which uses the most efficient way to get domains for the
+ available version of libvirt.
+ *)
val create_linux : [>`W] Connect.t -> xml -> rw t
(** Create a new guest domain (not necessarily a Linux one)
from the given XML.
See also {{:http://libvirt.org/hvsupport.html}http://libvirt.org/hvsupport.html}
*)
+(** {3 Utility functions} *)
+
+val map_ignore_errors : ('a -> 'b) -> 'a list -> 'b list
+(** [map_ignore_errors f xs] calls function [f] for each element of [xs].
+
+ This is just like [List.map] except that if [f x] throws a
+ {!Virterror.t} exception, the error is ignored and [f x]
+ is not returned in the final list.
+
+ This function is primarily useful when dealing with domains which
+ might 'disappear' asynchronously from the currently running
+ program.
+*)
+
+val get_domains : ([>`R] as 'a) Connect.t -> ?want_info:bool -> Domain.list_flag list -> 'a Domain.t list * Domain.info list
+ (** Get the active and/or inactive domains using the most
+ efficient method available.
+
+ The two lists returned will have the same length, unless
+ [~want_info] is [false] in which case the info list will be
+ zero-length. The default for [~want_info] is [true]. In most
+ cases there is no extra penalty for getting the info fields, or
+ the penalty is insignificant.
+
+ See also:
+ {!Domain.list_all_domains},
+ {!Connect.list_domains},
+ {!Connect.list_defined_domains}.
+ *)
#endif
}
+#ifdef HAVE_WEAK_SYMBOLS
+#ifdef HAVE_VIRCONNECTLISTALLDOMAINS
+extern int virConnectListAllDomains (virConnectPtr conn,
+ virDomainPtr **domains,
+ virDomainInfo **infos,
+ int stateflags)
+ __attribute__((weak));
+#endif
+#endif
+
+CAMLprim value
+ocaml_libvirt_connect_list_all_domains (value connv,
+ value wantinfov,
+ value flagsv)
+{
+#ifdef HAVE_VIRCONNECTLISTALLDOMAINS
+ CAMLparam3 (connv, wantinfov, flagsv);
+ CAMLlocal4 (flagv, rv, rv1, rv2);
+ CAMLlocal2 (v1, v2);
+ virConnectPtr conn = Connect_val (connv);
+ virDomainPtr *domains;
+ virDomainInfo *infos;
+ int want_info, i, r, flag, flags = 0;
+
+ /* ?want_info */
+ if (wantinfov == Val_int (0)) /* None == true */
+ want_info = 1;
+ else
+ want_info = Bool_val (Field (wantinfov, 0));
+
+ /* Iterate over the list of flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
+ flagv = Field (flagsv, 0);
+ flag = Int_val (flagv);
+ switch (flag) {
+ case 0: flags |= VIR_DOMAIN_LIST_NOSTATE; break;
+ case 1: flags |= VIR_DOMAIN_LIST_RUNNING; break;
+ case 2: flags |= VIR_DOMAIN_LIST_BLOCKED; break;
+ case 3: flags |= VIR_DOMAIN_LIST_PAUSED; break;
+ case 4: flags |= VIR_DOMAIN_LIST_SHUTDOWN; break;
+ case 5: flags |= VIR_DOMAIN_LIST_SHUTOFF; break;
+ case 6: flags |= VIR_DOMAIN_LIST_CRASHED; break;
+ case 7: flags |= VIR_DOMAIN_LIST_ACTIVE; break;
+ case 8: flags |= VIR_DOMAIN_LIST_INACTIVE; break;
+ case 9: flags |= VIR_DOMAIN_LIST_ALL; break;
+ }
+ }
+
+ WEAK_SYMBOL_CHECK (virConnectListAllDomains);
+ NONBLOCKING (r = virConnectListAllDomains (conn, &domains,
+ want_info ? &infos : NULL,
+ flags));
+ CHECK_ERROR (r == -1, conn, "virConnectListAllDomains");
+
+ /* Convert the result into a pair of arrays. */
+ rv1 = caml_alloc (r, 0);
+ for (i = 0; i < r; ++i) {
+ v1 = Val_domain (domains[i], connv);
+ Store_field (rv1, i, v1);
+ }
+ free (domains);
+
+ if (want_info) {
+ rv2 = caml_alloc (r, 0);
+
+ for (i = 0; i < r; ++i) {
+ v1 = caml_alloc (5, 0);
+ Store_field (v1, 0, Val_int (infos[i].state));
+ v2 = caml_copy_int64 (infos[i].maxMem); Store_field (v1, 1, v2);
+ v2 = caml_copy_int64 (infos[i].memory); Store_field (v1, 2, v2);
+ Store_field (v1, 3, Val_int (infos[i].nrVirtCpu));
+ v2 = caml_copy_int64 (infos[i].cpuTime); Store_field (v1, 4, v2);
+
+ Store_field (rv2, i, v1);
+ }
+
+ free (infos);
+ }
+ else
+ rv2 = caml_alloc (0, 0); /* zero-length array */
+
+ rv = caml_alloc_tuple (2);
+ Store_field (rv, 0, rv1);
+ Store_field (rv, 1, rv2);
+ CAMLreturn (rv);
+#else
+ not_supported ("virConnectListAllDomains");
+#endif
+}
+
CAMLprim value
ocaml_libvirt_domain_get_id (value domv)
{
| D.VcpuRunning -> s_"running"
| D.VcpuBlocked -> s_"blocked"
in
- let print_domain_array doms =
- Array.iter (
+ let print_domain_list doms =
+ List.iter (
fun dom ->
let id =
try sprintf "%d" (D.get_id dom)
s_"Print the hostname.",
[];
"list",
- cmd0 print_domain_array
+ cmd0 print_domain_list
(fun () ->
let c = get_readonly_connection () in
- let n = C.num_of_domains c in
- let domids = C.list_domains c n in
- Array.map (D.lookup_by_id c) domids),
+ fst (Libvirt.get_domains c ~want_info:false [D.ListActive])),
s_"List the running domains.",
[];
"list-defined",
- cmd0 print_domain_array
+ cmd0 print_domain_list
(fun () ->
let c = get_readonly_connection () in
- let n = C.num_of_defined_domains c in
- let domnames = C.list_defined_domains c n in
- Array.map (D.lookup_by_name c) domnames),
+ fst (Libvirt.get_domains c ~want_info:false [D.ListInactive])),
s_"List the defined but not running domains.",
[];
"quit",
git.annexia.org / ocaml-libvirt.git / commitdiff