(* Guestfs Browser.
 * Copyright (C) 2010 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this program; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

open Utils

module C = Libvirt.Connect
module Cond = Condition
module D = Libvirt.Domain
module G = Guestfs
module M = Mutex
module Q = Queue

type 'a callback = 'a -> unit

(* The commands. *)
type command =
  | Exit_thread
  | Connect of string option * unit callback
  | Get_domains of domain list callback

and domain = {
  dom_id : int;
  dom_name : string;
  dom_state : D.state;
}

let no_callback _ = ()

let failure_hook = ref (fun _ -> ())
let busy_hook = ref (fun _ -> ())
let idle_hook = ref (fun _ -> ())

let set_failure_hook cb = failure_hook := cb
let set_busy_hook cb = busy_hook := cb
let set_idle_hook cb = idle_hook := cb

(* Execute a function, while holding a mutex.  If the function
 * fails, ensure we release the mutex before rethrowing the
 * exception.
 *)
let with_lock m f =
  M.lock m;
  let r = try Left (f ()) with exn -> Right exn in
  M.unlock m;
  match r with
  | Left r -> r
  | Right exn -> raise exn

(* The queue of commands, and a lock and condition to protect it. *)
let q = Q.create ()
let q_lock = M.create ()
let q_cond = Cond.create ()

(* Send a command message to the slave thread. *)
let send_to_slave cmd =
  debug "sending message %s to slave thread ..." (string_of_command cmd)
  with_lock q_lock (
    fun () ->
      Q.push cmd q;
      Cond.signal q_cond
  )

let discard_command_queue () = with_lock q_lock (fun () -> Q.clear q)

let connect uri cb = send_to_slave (Connect (uri, cb))
let get_domains cb = send_to_slave (Get_domains cb)

(*----- Slave thread starts here -----*)

(* Set this to true to exit the thread. *)
let quit = ref false

let rec loop () =
  (* Get the next command. *)
  let cmd =
    with_lock q_lock (
      fun () ->
        while Q.is_empty q do
          Cond.wait q_cond q_lock
        done;
        Q.pop q
    ) in

  debug "slave thread processing command %s ..." (string_of_command cmd);

  (try
     call_callback !busy_hook ();
     execute_command cmd;
     call_callback !idle_hook ();
   with exn ->
     (* If a command fails, clear the command queue and run the
      * failure hook in the main thread.
      *)
     call_callback !idle_hook ();
     discard_command_queue ();
     call_callback !failure_hook exn
  );

  if !quit then Thread.exit ();
  loop ()

and execute_command = function
  | Exit_thread ->
      quit := true;
      disconnect_all ()

  | Connect (uri, cb) ->
      disconnect_all ();
      conn := Some (C.connect_readonly ?uri ());
      call_callback cb ()

  | Get_domains cb ->
      let conn = get_conn () in
      let doms = D.get_domains conn [D.ListAll] in
      let doms = List.map (
        fun d ->
          D.get_id d, D.get_name d, (D.get_info d).D.state
      ) doms in
      call_callback cb doms

(* Call a callback function or hook in the main thread. *)
and call_callback cb arg =
  GtkThread.async cb arg

(* Expect to be connected, and return the current libvirt connection. *)
let get_conn () =
  match !conn with
  | Some conn -> conn
  | None -> failwith "not connected to libvirt"

(* Close all libvirt and libguestfs handles. *)
and disconnect_all () =
  (match !conn with Some conn -> C.close conn | None -> ());
  conn := None

(* Start up one slave thread. *)
let slave_thread = Thread.create loop ()

(* Note the following function is called from the main thread. *)
let exit_thread () =
  discard_command_queue ();
  send_to_slave Exit_thread;
  Thread.join slave_thread