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