From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Mon, 1 Sep 2008 14:54:45 +0000 (+0100) Subject: Add support for virConnectListAllDomains call. X-Git-Tag: 0.6.1.1~15 X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=4d988dada41d62c5f40a24c69220184ff6b079e0;p=ocaml-libvirt.git Add support for virConnectListAllDomains call. --- diff --git a/config.h.in b/config.h.in index 68f6bbf..50d3724 100644 --- a/config.h.in +++ b/config.h.in @@ -36,6 +36,9 @@ /* 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 diff --git a/configure.ac b/configure.ac index 5951887..acca266 100644 --- a/configure.ac +++ b/configure.ac @@ -125,6 +125,7 @@ AC_CHECK_FUNCS([virConnectGetHostname \ virStorageVolGetPath \ virDomainBlockPeek \ virDomainMemoryPeek \ + virConnectListAllDomains \ ]) # This jobs API was never published and is due to get overhauled diff --git a/examples/list_domains.ml b/examples/list_domains.ml index c97432c..2e9e436 100644 --- a/examples/list_domains.ml +++ b/examples/list_domains.ml @@ -20,21 +20,20 @@ let () = 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) diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml index daf7f38..1e37136 100644 --- a/libvirt/libvirt.ml +++ b/libvirt/libvirt.ml @@ -50,6 +50,13 @@ struct 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" @@ -133,6 +140,13 @@ struct 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; @@ -158,6 +172,8 @@ struct *) 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" @@ -520,6 +536,105 @@ end 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 () = diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli index ec945b7..052d4c0 100644 --- a/libvirt/libvirt.mli +++ b/libvirt/libvirt.mli @@ -61,47 +61,46 @@ v} {{: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; @@ -117,7 +116,7 @@ printf "hostname = %s\n%!" hostname; let uri = C.get_uri conn in printf "uri = %s\n%!" uri -v} +]} *) @@ -140,7 +139,7 @@ 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} @@ -158,6 +157,14 @@ v} 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 @@ -227,17 +234,23 @@ type ro = [`R] 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} *) @@ -293,7 +306,10 @@ sig 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. *) @@ -305,7 +321,10 @@ sig (** [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. *) @@ -395,7 +414,7 @@ sig | 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 *) @@ -421,6 +440,13 @@ sig 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; @@ -445,6 +471,26 @@ sig 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. @@ -1008,3 +1054,32 @@ exception Not_supported of string 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}. + *) diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c index ff69105..4d69bd1 100644 --- a/libvirt/libvirt_c_oneoffs.c +++ b/libvirt/libvirt_c_oneoffs.c @@ -194,6 +194,96 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value connv, #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) { diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml index 4c77e7f..9fd3779 100644 --- a/mlvirsh/mlvirsh.ml +++ b/mlvirsh/mlvirsh.ml @@ -302,8 +302,8 @@ let do_command = | 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) @@ -576,21 +576,17 @@ let do_command = 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",