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     (* http://plus.kaist.ac.kr/~shoh/ocaml/lablgtk2/treeview-tutorial/ch05s08.html *)
 104     let col_icon = cols#add (Gobject.Data.gobject_by_name "GdkPixbuf") in
 105     let col_name = cols#add Gobject.Data.string in
 106     let model = GTree.list_store cols in
 107
 108     let icons = GTree.icon_view
 109       ~selection_mode:`SINGLE ~model
 110       ~height:200
 111       ~packing:(vbox#pack ~expand:true ~fill:true) () in
 112     icons#set_border_width 4;
 113
 114     icons#set_pixbuf_column col_icon;
 115     icons#set_text_column col_name;
 116
 117     let refresh () =
 118       model#clear ();
 119       let services = !find_libvirtd_with_zeroconf () in
 120
 121       let pixbuf = !icon_32x32_devices_computer_png in
 122       List.iter (
 123         fun (name, _) ->
 124           let row = model#append () in
 125           model#set ~row ~column:col_name name;
 126           match pixbuf with
 127           | None -> ()
 128           | Some pixbuf -> model#set ~row ~column:col_icon pixbuf
 129       ) services
 130     in
 131     refresh ();
 132
 133     let hbox = GPack.hbox ~packing:vbox#pack () in
 134     let refresh_button =
 135       GButton.button ~label:(s_ "Refresh")
 136         ~stock:`REFRESH ~packing:hbox#pack () in
 137     let open_button =
 138       GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
 139
 140     ignore (refresh_button#connect#clicked ~callback:refresh);
 141
 142     (* Function callback when someone selects and hits Open. *)
 143     let callback () =
 144       match icons#get_selected_items with
 145       | [] -> () (* nothing selected *)
 146       | path :: _ ->
 147           let row = model#get_iter path in
 148           let name = model#get ~row ~column:col_name in
 149           let services = !find_libvirtd_with_zeroconf () in
 150           try
 151             uri := Some (List.assoc name services);
 152             dlg#destroy ()
 153           with
 154             Not_found -> () in
 155
 156     ignore (open_button#connect#clicked ~callback) in
 157
 158   (* Custom connections. *)
 159   let () =
 160     let frame =
 161       GBin.frame ~label:(s_ "URI connection") ~packing:vbox#pack () in
 162     let hbox = GPack.hbox ~packing:frame#add () in
 163     hbox#set_spacing 20;
 164     ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ());
 165
 166     let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in
 167     let entry =
 168       GEdit.entry ~text:"xen://localhost/"
 169         ~packing:(hbox#pack ~expand:true ~fill:true) () in
 170     let button =
 171       GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
 172
 173     ignore (button#connect#clicked
 174               ~callback:(fun () ->
 175                            uri := Some entry#text;
 176                            dlg#destroy ()));
 177
 178     () in
 179
 180
 181   (* Just a cancel button in the action area. *)
 182   let cancel_button =
 183     GButton.button ~label:(s_ "Cancel")
 184       ~packing:dlg#action_area#pack () in
 185   ignore (cancel_button#connect#clicked
 186             ~callback:(fun () ->
 187                          uri := None;
 188                          dlg#destroy ()));
 189
 190   dlg#show ();
 191
 192   (* Enter Gtk main loop recursively. *)
 193   GMain.main ();
 194
 195   match !uri with
 196   | None -> ()
 197   | Some uri -> Vc_connections.open_connection uri
 198
 199 (* Callback from the Connect button drop-down menu. *)
 200 let open_local_xen () =
 201   Vc_connections.open_connection local_xen_uri
 202
 203 let open_local_qemu () =
 204   Vc_connections.open_connection local_qemu_uri