mclu_list.ml

   1 (* mclu: Mini Cloud
   2  * Copyright (C) 2014-2015 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 (* Implement 'mclu list'. *)
  20
  21 open Printf
  22
  23 open Utils
  24
  25 module C = Libvirt.Connect
  26 module D = Libvirt.Domain
  27
  28 let list_what = ref `All
  29 let set_all () = list_what := `All
  30 let set_active () = list_what := `ActiveOnly
  31 let set_templates () = list_what := `TemplatesOnly
  32
  33 let get_arg_speclist () = Arg.align [
  34   "--active", Arg.Unit set_active, " List only active/running guests";
  35   "--all", Arg.Unit set_all, " List active guests and templates (default)";
  36   "--inactive", Arg.Unit set_templates, " List only templates";
  37   "--running", Arg.Unit set_active, " List only active/running guests";
  38   "--templates", Arg.Unit set_templates, " List only templates";
  39 ]
  40
  41 type dom_info = {
  42   dom_name : string;
  43   dom_info : D.info;
  44 }
  45
  46 (* Return the active (running) guests.  This utility function is
  47  * also called from other places.
  48  *)
  49 let active_guests ?(verbose = false) ?(nodes = Mclu_conf.nodes ()) () =
  50   (* A list of running guests, indexed by each node. *)
  51   let active_guests =
  52     Parallel.map (
  53       fun node ->
  54         let hostname = node.Mclu_conf.hostname
  55         and name = node.Mclu_conf.libvirt_uri in
  56         let conn =
  57           try Some (C.connect_readonly ~name ())
  58           with Libvirt.Virterror msg ->
  59             if verbose then
  60               eprintf "mclu: %s: %s (ignored)\n" hostname
  61                 (Libvirt.Virterror.to_string msg);
  62             None in
  63         let dominfo =
  64           match conn with
  65           | Some conn ->
  66             let dominfos = D.get_domains_and_infos conn [D.ListActive] in
  67             (* D.t is abstract so we cannot marshal it. *)
  68             filter_map (
  69               fun (dom, info) ->
  70                 let name = D.get_name dom in
  71                 let name_len = String.length name in
  72                 if name_len > 8 && String.sub name 0 8 = "guestfs-" then
  73                   None
  74                 else
  75                   Some { dom_name = D.get_name dom; dom_info = info }
  76             ) dominfos
  77           | None -> [] in
  78         (node, dominfo)
  79     ) nodes in
  80   List.map (fun s -> Marshal.from_bytes s 0) active_guests
  81
  82 let find_guest ?verbose ?(nodes = Mclu_conf.nodes ()) name =
  83   let host, name = name_parse name in
  84   let node =
  85     match host with
  86     | Some host ->
  87       (try List.find (fun n -> host = n.Mclu_conf.hostname) nodes
  88        with Not_found ->
  89          eprintf "mclu: host '%s' not found\n" host;
  90          exit 1)
  91     | None ->
  92       (* No 'host:' prefix given, so we need to find the host. *)
  93       let guests = active_guests ?verbose ~nodes () in
  94       let node, _ =
  95         try
  96           List.find (
  97             fun (node, doms) ->
  98               List.exists (fun dom -> name = dom.dom_name) doms
  99           ) guests
 100         with
 101           Not_found ->
 102             eprintf "mclu: guest '%s' not found\n" name;
 103             exit 1 in
 104       node in
 105   node, name
 106
 107 let list ~verbose () =
 108   let list_what = !list_what in
 109
 110   (match list_what with
 111   | `TemplatesOnly -> ()
 112   | `All | `ActiveOnly ->
 113     let active_guests = active_guests ~verbose () in
 114
 115     List.iter (
 116       fun ({ Mclu_conf.hostname = hostname }, dominfos) ->
 117         List.iter (
 118           fun { dom_name = name;
 119                 dom_info = { D.nr_virt_cpu = vcpus;
 120                              D.memory = memory_kb;
 121                              D.state = state } } ->
 122             let host_dom_name = sprintf "%s:%s" hostname name in
 123             printf "%-28s %s %dvcpus %s\n"
 124               host_dom_name (string_of_dom_state state)
 125               vcpus (human_size (memory_kb *^ 1024L))
 126         ) dominfos
 127     ) active_guests
 128   );
 129
 130   (* For quasi-historical reasons, this command also lists the inactive
 131    * guests, which in mclu v2 are templates.
 132    *)
 133   (match list_what with
 134   | `ActiveOnly -> ()
 135   | `All | `TemplatesOnly ->
 136     let templates = Template.template_names () in
 137
 138     List.iter (
 139       fun name ->
 140         printf "%-28s template\n" name
 141     ) templates
 142   )
 143
 144 let run ~verbose = function
 145   | [] -> list ~verbose ()
 146   | _ ->
 147     eprintf "mclu list: Too many arguments\n";
 148     exit 1