Initial import from CVS.
[virt-top.git] / mlvirtmanager / mlvirtmanager_mainwindow.ml
1 (* virt-manager-like graphical management tool.
2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
3    http://libvirt.org/
4    $Id: mlvirtmanager_mainwindow.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
5 *)
6
7 open Printf
8
9 let title = "Virtual Machine Manager"
10
11 let utf8_copyright = "\194\169"
12
13 let help_about () =
14   let gtk_version =
15     let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
16     sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
17   let virt_version = string_of_int (fst (Libvirt.get_version ())) in
18   let title = "About " ^ title in
19   let icon = GMisc.image () in
20   icon#set_stock `DIALOG_INFO;
21   icon#set_icon_size `DIALOG;
22   GToolbox.message_box
23     ~title
24     ~icon
25     ("Virtual machine manager (OCaml version) by\n" ^
26      "Richard W.M. Jones (rjones@redhat.com).\n\n" ^
27      "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^
28      "Libvirt version: " ^ virt_version ^ "\n" ^
29      "Gtk toolkit version: " ^ gtk_version)
30
31 (* Catch any exception and throw up a dialog. *)
32 let () =
33   (* A nicer exception printing function. *)
34   let string_of_exn = function
35     | Libvirt.Virterror err ->
36         "Virtualisation error: " ^ (Libvirt.Virterror.to_string err)
37     | Failure msg -> msg
38     | exn -> Printexc.to_string exn
39   in
40   GtkSignal.user_handler :=
41     fun exn ->
42       let label = string_of_exn exn in
43       let title = "Error" in
44       let icon = GMisc.image () in
45       icon#set_stock `DIALOG_ERROR;
46       icon#set_icon_size `DIALOG;
47       GToolbox.message_box ~title ~icon label
48
49 let make ~open_connection
50     ~start_domain ~pause_domain ~resume_domain ~shutdown_domain =
51   (* Create the main window. *)
52   let window = GWindow.window ~width:800 ~height:600 ~title () in
53   let vbox = GPack.vbox ~packing:window#add () in
54
55   (* Menu bar. *)
56   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
57   let factory = new GMenu.factory menubar in
58   let accel_group = factory#accel_group in
59   let file_menu = factory#add_submenu "File" in
60   let help_menu = factory#add_submenu "Help" in
61
62   (* File menu. *)
63   let factory = new GMenu.factory file_menu ~accel_group in
64   let open_item = factory#add_item "Open connection ..."
65     ~key:GdkKeysyms._O in
66   ignore (factory#add_separator ());
67   let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
68
69   ignore (open_item#connect#activate ~callback:open_connection);
70
71   (* Help menu. *)
72   let factory = new GMenu.factory help_menu ~accel_group in
73   let help_item = factory#add_item "Help" in
74   let help_about_item = factory#add_item "About ..." in
75
76   ignore (help_about_item#connect#activate ~callback:help_about);
77
78   (* The toolbar. *)
79   let toolbar = GButton.toolbar ~packing:vbox#pack () in
80   let connect_button =
81     GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
82       ~packing:toolbar#insert () in
83   let start_button =
84     GButton.tool_button ~label:"Start" ~stock:`ADD
85       ~packing:toolbar#insert () in
86   let pause_button =
87     GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
88       ~packing:toolbar#insert () in
89   let resume_button =
90     GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
91       ~packing:toolbar#insert () in
92   let shutdown_button =
93     GButton.tool_button ~label:"Shutdown" ~stock:`STOP
94       ~packing:toolbar#insert () in
95   ignore (connect_button#connect#clicked ~callback:open_connection);
96
97   (* The treeview. *)
98   let (tree, model, columns, initial_state) =
99     Mlvirtmanager_connections.make_treeview
100       ~packing:(vbox#pack ~expand:true ~fill:true) () in
101
102   ignore (start_button#connect#clicked
103             ~callback:(start_domain tree model columns));
104   ignore (pause_button#connect#clicked
105             ~callback:(pause_domain tree model columns));
106   ignore (resume_button#connect#clicked
107             ~callback:(resume_domain tree model columns));
108   ignore (shutdown_button#connect#clicked
109             ~callback:(shutdown_domain tree model columns));
110
111   (* Make a timeout function which is called once per second. *)
112   let state = ref initial_state in
113   let callback () =
114     state := Mlvirtmanager_connections.repopulate tree model columns !state;
115     true
116   in
117   let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
118
119   (* Quit. *)
120   let quit _ =
121     GMain.Timeout.remove timeout_id;
122     GMain.Main.quit ();
123     false
124   in
125
126   ignore (window#connect#destroy ~callback:GMain.quit);
127   ignore (window#event#connect#delete ~callback:quit);
128   ignore (quit_item#connect#activate
129             ~callback:(fun () -> ignore (quit ()); ()));
130
131   window#add_accel_group accel_group;
132
133   (* Display the window. *)
134   window#show ()