2 * Copyright (C) 2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 module C = Libvirt.Connect
22 module Cond = Condition
23 module D = Libvirt.Domain
28 type 'a callback = 'a -> unit
33 | Connect of string option * unit callback
34 | Get_domains of domain list callback
42 let no_callback _ = ()
44 let failure_hook = ref (fun _ -> ())
45 let busy_hook = ref (fun _ -> ())
46 let idle_hook = ref (fun _ -> ())
48 let set_failure_hook cb = failure_hook := cb
49 let set_busy_hook cb = busy_hook := cb
50 let set_idle_hook cb = idle_hook := cb
52 (* Execute a function, while holding a mutex. If the function
53 * fails, ensure we release the mutex before rethrowing the
58 let r = try Left (f ()) with exn -> Right exn in
62 | Right exn -> raise exn
64 (* The queue of commands, and a lock and condition to protect it. *)
66 let q_lock = M.create ()
67 let q_cond = Cond.create ()
69 (* Send a command message to the slave thread. *)
70 let send_to_slave cmd =
71 debug "sending message %s to slave thread ..." (string_of_command cmd)
78 let discard_command_queue () = with_lock q_lock (fun () -> Q.clear q)
80 let connect uri cb = send_to_slave (Connect (uri, cb))
81 let get_domains cb = send_to_slave (Get_domains cb)
83 (*----- Slave thread starts here -----*)
85 (* Set this to true to exit the thread. *)
89 (* Get the next command. *)
94 Cond.wait q_cond q_lock
99 debug "slave thread processing command %s ..." (string_of_command cmd);
102 call_callback !busy_hook ();
104 call_callback !idle_hook ();
106 (* If a command fails, clear the command queue and run the
107 * failure hook in the main thread.
109 call_callback !idle_hook ();
110 discard_command_queue ();
111 call_callback !failure_hook exn
114 if !quit then Thread.exit ();
117 and execute_command = function
122 | Connect (uri, cb) ->
124 conn := Some (C.connect_readonly ?uri ());
128 let conn = get_conn () in
129 let doms = D.get_domains conn [D.ListAll] in
130 let doms = List.map (
132 D.get_id d, D.get_name d, (D.get_info d).D.state
134 call_callback cb doms
136 (* Call a callback function or hook in the main thread. *)
137 and call_callback cb arg =
138 GtkThread.async cb arg
140 (* Expect to be connected, and return the current libvirt connection. *)
144 | None -> failwith "not connected to libvirt"
146 (* Close all libvirt and libguestfs handles. *)
147 and disconnect_all () =
148 (match !conn with Some conn -> C.close conn | None -> ());
151 (* Start up one slave thread. *)
152 let slave_thread = Thread.create loop ()
154 (* Note the following function is called from the main thread. *)
156 discard_command_queue ();
157 send_to_slave Exit_thread;
158 Thread.join slave_thread