f072a1d946584baff7c05d8a85572d7aaf80af50
[virt-ctrl.git] / virt-ctrl / vc_connection_dlg.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
20 open Virt_ctrl_gettext.Gettext
21
22 type name = string
23 type uri = string
24 type service = name * uri
25
26 let local_xen_uri = "xen:///"
27 let local_qemu_uri = "qemu:///system"
28
29 (* Code in Vc_dbus overrides this, if that capability was compiled in. *)
30 let find_libvirtd_with_zeroconf = ref (fun () -> [])
31
32 (* Code in Vc_icons may override these with icons. *)
33 let icon_16x16_devices_computer_png = ref None
34 let icon_24x24_devices_computer_png = ref None
35 let icon_32x32_devices_computer_png = ref None
36 let icon_48x48_devices_computer_png = ref None
37
38 (* Open connection dialog. *)
39 let open_connection parent () =
40   let title = s_ "Open connection to hypervisor" in
41   let position = `CENTER_ON_PARENT in
42
43   let dlg = GWindow.dialog ~title ~position ~parent
44     ~modal:true ~width:450 () in
45
46   (* We will enter the Gtk main loop recursively.  Wire up close and
47    * other buttons to quit the recursive main loop.
48    *)
49   ignore (dlg#connect#destroy ~callback:GMain.quit);
50   ignore (dlg#event#connect#delete
51             ~callback:(fun _ -> GMain.quit (); false));
52
53   let uri = ref None in
54
55   (* Pack the buttons into the dialog. *)
56   let vbox = dlg#vbox in
57   vbox#set_spacing 5;
58
59   (* Local connections. *)
60   let () =
61     let frame =
62       GBin.frame ~label:(s_ "This machine") ~packing:vbox#pack () in
63     let hbox = GPack.hbox ~packing:frame#add () in
64     hbox#set_spacing 20;
65     ignore (
66       let packing = hbox#pack in
67       match !icon_24x24_devices_computer_png with
68       | None -> GMisc.image ~stock:`DIRECTORY ~packing ()
69       | Some pixbuf -> GMisc.image ~pixbuf ~packing ()
70     );
71
72     let vbox = GPack.vbox ~packing:hbox#pack () in
73     vbox#set_spacing 5;
74
75     let xen_button =
76       GButton.button ~label:(s_ "Xen hypervisor")
77         ~packing:vbox#pack () in
78     ignore (xen_button#connect#clicked
79               ~callback:(fun () ->
80                            uri := Some local_xen_uri;
81                            dlg#destroy ()));
82     let qemu_button =
83       GButton.button ~label:(s_ "QEMU or KVM")
84         ~packing:vbox#pack () in
85     ignore (qemu_button#connect#clicked
86               ~callback:(fun () ->
87                            uri := Some local_qemu_uri;
88                            dlg#destroy ())) in
89
90   (* Network connections. *)
91   let () =
92     let frame =
93       GBin.frame ~label:(s_ "Local network")
94         ~packing:(vbox#pack ~expand:true) () in
95     let hbox = GPack.hbox ~packing:frame#add () in
96     hbox#set_spacing 20;
97     ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ());
98
99     let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in
100     vbox#set_spacing 5;
101
102     let cols = new GTree.column_list in
103     (*let col_icon = cols#add Gobject.Data.string in*)
104     let col_name = cols#add Gobject.Data.string in
105     let model = GTree.list_store cols in
106
107     let icons = GTree.icon_view
108       ~selection_mode:`SINGLE ~model
109       ~height:200
110       ~packing:(vbox#pack ~expand:true ~fill:true) () in
111     icons#set_border_width 4;
112
113     (*icons#set_pixbuf_column col_icon;*)
114     icons#set_text_column col_name;
115
116     let refresh () =
117       model#clear ();
118       let services = !find_libvirtd_with_zeroconf () in
119
120       (*let pixbuf = !icon_16x16_devices_computer_png in*)
121       List.iter (
122         fun (name, _) ->
123           let row = model#append () in
124           model#set ~row ~column:col_name name;
125           (*match pixbuf with
126             | None -> ()
127             | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*)
128       ) services
129     in
130     refresh ();
131
132     let hbox = GPack.hbox ~packing:vbox#pack () in
133     let refresh_button =
134       GButton.button ~label:(s_ "Refresh")
135         ~stock:`REFRESH ~packing:hbox#pack () in
136     let open_button =
137       GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
138
139     ignore (refresh_button#connect#clicked ~callback:refresh);
140
141     (* Function callback when someone selects and hits Open. *)
142     let callback () =
143       match icons#get_selected_items with
144       | [] -> () (* nothing selected *)
145       | path :: _ ->
146           let row = model#get_iter path in
147           let name = model#get ~row ~column:col_name in
148           let services = !find_libvirtd_with_zeroconf () in
149           try
150             uri := Some (List.assoc name services);
151             dlg#destroy ()
152           with
153             Not_found -> () in
154
155     ignore (open_button#connect#clicked ~callback) in
156
157   (* Custom connections. *)
158   let () =
159     let frame =
160       GBin.frame ~label:(s_ "URI connection") ~packing:vbox#pack () in
161     let hbox = GPack.hbox ~packing:frame#add () in
162     hbox#set_spacing 20;
163     ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ());
164
165     let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in
166     let entry =
167       GEdit.entry ~text:"xen://localhost/"
168         ~packing:(hbox#pack ~expand:true ~fill:true) () in
169     let button =
170       GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
171
172     ignore (button#connect#clicked
173               ~callback:(fun () ->
174                            uri := Some entry#text;
175                            dlg#destroy ()));
176
177     () in
178
179
180   (* Just a cancel button in the action area. *)
181   let cancel_button =
182     GButton.button ~label:(s_ "Cancel")
183       ~packing:dlg#action_area#pack () in
184   ignore (cancel_button#connect#clicked
185             ~callback:(fun () ->
186                          uri := None;
187                          dlg#destroy ()));
188
189   dlg#show ();
190
191   (* Enter Gtk main loop recursively. *)
192   GMain.main ();
193
194   match !uri with
195   | None -> ()
196   | Some uri -> Vc_connections.open_connection uri
197
198 (* Callback from the Connect button drop-down menu. *)
199 let open_local_xen () =
200   Vc_connections.open_connection local_xen_uri
201
202 let open_local_qemu () =
203   Vc_connections.open_connection local_qemu_uri