mclu version 2

[mclu.git] / mclu_list.ml

diff --git a/mclu_list.ml b/mclu_list.ml
new file mode 100644 (file)
index 0000000..3534066
--- /dev/null
+++ b/mclu_list.ml
@@ -0,0 +1,118 @@
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(* Implement 'mclu list'. *)
+
+open Printf
+
+open Utils
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+let list_what = ref `All
+let set_all () = list_what := `All
+let set_active () = list_what := `ActiveOnly
+let set_templates () = list_what := `TemplatesOnly
+
+let get_arg_speclist () = Arg.align [
+  "--active", Arg.Unit set_active, " List only active/running guests";
+  "--all", Arg.Unit set_all, " List active guests and templates (default)";
+  "--inactive", Arg.Unit set_templates, " List only templates";
+  "--running", Arg.Unit set_active, " List only active/running guests";
+  "--templates", Arg.Unit set_templates, " List only templates";
+]
+
+type dom_info = {
+  dom_name : string;
+  dom_info : D.info;
+}
+
+(* Return the active (running) guests.  This utility function is
+ * also called from other places.
+ *)
+let active_guests ?(verbose = false) ?(nodes = Mclu_conf.nodes ()) () =
+  (* A list of running guests, indexed by each node. *)
+  let active_guests =
+    Parallel.map (
+      fun node ->
+        let hostname = node.Mclu_conf.hostname
+        and name = node.Mclu_conf.libvirt_uri in
+        let conn =
+          try Some (C.connect_readonly ~name ())
+          with Libvirt.Virterror msg ->
+            if verbose then
+              eprintf "mclu: %s: %s (ignored)\n" hostname
+                (Libvirt.Virterror.to_string msg);
+            None in
+        let dominfo =
+          match conn with
+          | Some conn ->
+            let dominfos = D.get_domains_and_infos conn [D.ListActive] in
+            (* D.t is abstract so we cannot marshal it. *)
+            List.map (
+              fun (dom, info) ->
+                { dom_name = D.get_name dom; dom_info = info }
+            ) dominfos
+          | None -> [] in
+        (node, dominfo)
+    ) nodes in
+  List.map (fun s -> Marshal.from_bytes s 0) active_guests
+
+let list ~verbose () =
+  let list_what = !list_what in
+
+  (match list_what with
+  | `TemplatesOnly -> ()
+  | `All | `ActiveOnly ->
+    let active_guests = active_guests ~verbose () in
+
+    List.iter (
+      fun ({ Mclu_conf.hostname = hostname }, dominfos) ->
+        List.iter (
+          fun { dom_name = name;
+                dom_info = { D.nr_virt_cpu = vcpus;
+                             D.memory = memory_kb;
+                             D.state = state } } ->
+            let host_dom_name = sprintf "%s:%s" hostname name in
+            printf "%-28s %s %dvcpus %s\n"
+              host_dom_name (string_of_dom_state state)
+              vcpus (human_size (memory_kb *^ 1024L))
+        ) dominfos
+    ) active_guests
+  );
+
+  (* For quasi-historical reasons, this command also lists the inactive
+   * guests, which in mclu v2 are templates.
+   *)
+  (match list_what with
+  | `ActiveOnly -> ()
+  | `All | `TemplatesOnly ->
+    let templates = Template.template_names () in
+
+    List.iter (
+      fun name ->
+        printf "%-28s template\n" name
+    ) templates
+  )
+
+let run ~verbose = function
+  | [] -> list ~verbose ()
+  | _ ->
+    eprintf "mclu list: Too many arguments\n";
+    exit 1