Type Vc_domain_ops.dops_callback_fn for clarity.
[virt-top.git] / virt-ctrl / vc_domain_ops.ml
1 (* virt-ctrl: A graphical management tool.
2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
3    http://libvirt.org/
4
5    This program is free software; you can redistribute it and/or modify
6    it under the terms of the GNU General Public License as published by
7    the Free Software Foundation; either version 2 of the License, or
8    (at your option) any later version.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13    GNU General Public License for more details.
14
15    You should have received a copy of the GNU General Public License
16    along with this program; if not, write to the Free Software
17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18
19    Domain operations buttons.
20 *)
21
22 open Printf
23
24 module C = Libvirt.Connect
25 module D = Libvirt.Domain
26 module N = Libvirt.Network
27
28 (* Get the selected domain (if there is one) or return None. *)
29 let get_domain (tree : GTree.view) (model : GTree.tree_store)
30     (columns : Vc_connections.columns) =
31   let path, _ = tree#get_cursor () in
32   match path with
33   | None -> None                        (* No row at all selected. *)
34   | Some path ->
35       let row = model#get_iter path in
36       (* Visit parent to get the conn_id.
37        * If this returns None, then it's a top-level row which is
38        * selected (ie. a connection), so just ignore.
39        *)
40       match model#iter_parent row with
41       | None -> None
42       | Some parent ->
43           try
44             let (_, col_domname, _, _, _, col_id) = columns in
45             let conn_id = model#get ~row:parent ~column:col_id in
46             let conn =
47               List.assoc conn_id (Vc_connections.get_conns ()) in
48             let domid = model#get ~row ~column:col_id in
49             if domid = -1 then (        (* Inactive domain. *)
50               let domname = model#get ~row ~column:col_domname in
51               let dom = D.lookup_by_name conn domname in
52               let info = D.get_info dom in
53               Some (dom, info, -1)
54             ) else if domid > 0 then (  (* Active domU. *)
55               let dom = D.lookup_by_id conn domid in
56               let info = D.get_info dom in
57               Some (dom, info, domid)
58             ) else                      (* Dom0 - ignore. *)
59               None
60           with
61             (* Domain or connection disappeared under us. *)
62           | Not_found -> None
63           | Failure msg ->
64               prerr_endline msg;
65               None
66           | Libvirt.Virterror err ->
67               prerr_endline (Libvirt.Virterror.to_string err);
68               None
69
70 type dops_callback_fn =
71     GTree.view -> GTree.tree_store -> Vc_connections.columns -> unit -> unit
72
73 let start_domain tree model columns () =
74   match get_domain tree model columns with
75   | None -> ()
76   | Some (dom, _, domid) ->
77       if domid = -1 then
78         D.create dom
79
80 let pause_domain tree model columns () =
81   match get_domain tree model columns with
82   | None -> ()
83   | Some (dom, info, domid) ->
84       if domid >= 0 && info.D.state <> D.InfoPaused then
85         D.suspend dom
86
87 let resume_domain tree model columns () =
88   match get_domain tree model columns with
89   | None -> ()
90   | Some (dom, info, domid) ->
91       if domid >= 0 && info.D.state = D.InfoPaused then
92         D.resume dom
93
94 let shutdown_domain tree model columns () =
95   match get_domain tree model columns with
96   | None -> ()
97   | Some (dom, info, domid) ->
98       if domid >= 0 && info.D.state <> D.InfoShutdown then
99         D.shutdown dom