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