slave.ml

   1 (* Virt-resize UI.
   2  * Copyright (C) 2011 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 open Printf
  20
  21 open Slave_types
  22 open Utils
  23
  24 (*module C = Libvirt.Connect*)
  25 module Cond = Condition
  26 (*module D = Libvirt.Domain*)
  27 module G = Guestfs
  28 module M = Mutex
  29 module Q = Queue
  30
  31 (* Callbacks. *)
  32 type 'a callback = 'a -> unit
  33 let no_callback _ = ()
  34
  35 (* Hooks. *)
  36 let failure_hook = ref (fun _ -> ())
  37 let busy_hook = ref (fun _ -> ())
  38 let idle_hook = ref (fun _ -> ())
  39 let status_hook = ref (fun _ -> ())
  40 let progress_hook = ref (fun _ -> ())
  41
  42 let set_failure_hook cb = failure_hook := cb
  43 let set_busy_hook cb = busy_hook := cb
  44 let set_idle_hook cb = idle_hook := cb
  45 let set_status_hook cb = status_hook := cb
  46 let set_progress_hook cb = progress_hook := cb
  47
  48 (* Messages. *)
  49 type message =
  50   | Exit_thread
  51   | Open_images of (string * string option) list * inspection_data callback
  52
  53 let rec string_of_message = function
  54   | Exit_thread -> "Exit_thread"
  55   | Open_images (images, _) ->
  56     sprintf "Open_images %s" (string_of_images images)
  57
  58 and string_of_images images =
  59   "[" ^
  60     String.concat "; "
  61     (List.map (
  62       function
  63       | fn, None -> fn
  64       | fn, Some format -> sprintf "%s (%s)" fn format
  65      ) images) ^
  66     "]"
  67
  68 (* Execute a function, while holding a mutex.  If the function
  69  * fails, ensure we release the mutex before rethrowing the
  70  * exception.
  71  *)
  72 let with_lock m f =
  73   M.lock m;
  74   let r = try Left (f ()) with exn -> Right exn in
  75   M.unlock m;
  76   match r with
  77   | Left r -> r
  78   | Right exn -> raise exn
  79
  80 (* The queue of commands, and a lock and condition to protect it. *)
  81 let q = Q.create ()
  82 let q_discard = ref false
  83 let q_lock = M.create ()
  84 let q_cond = Cond.create ()
  85
  86 (* Send a command message to the slave thread. *)
  87 let send_message ?fail msg =
  88   debug "sending message %s to slave thread ..." (string_of_message msg);
  89   with_lock q_lock (
  90     fun () ->
  91       Q.push (fail, msg) q;
  92       Cond.signal q_cond
  93   )
  94
  95 let discard_command_queue () =
  96   with_lock q_lock (
  97     fun () ->
  98       Q.clear q;
  99       (* Discard the currently running command too. *)
 100       q_discard := true
 101   )
 102
 103 (*----------------------------------------------------------------------*)
 104 (* This is the slave thread. *)
 105
 106 (* Run the callback unless someone set the q_discard flag while we
 107    were running the command.  This allows discard_command_queue () to
 108    discard both the command queue and the running command (although
 109    the running command is not interrupted). *)
 110 let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
 111   let discard = with_lock q_lock (fun () -> !q_discard) in
 112   if not discard then
 113     GtkThread.async cb arg
 114
 115 (* Set this to true to exit the thread. *)
 116 let quit = ref false
 117
 118 (* Handles.  These are not protected by locks because only the slave
 119  * thread has access to them.
 120  *)
 121 (*let conn = ref None*)
 122 let g = ref None
 123
 124 (* Update the status bar. *)
 125 let status fs =
 126   let f str = GtkThread.async !status_hook str in
 127   ksprintf f fs
 128
 129 let rec loop () =
 130   debug "top of slave loop";
 131
 132   (* Get the next command. *)
 133   let fail, cmd =
 134     with_lock q_lock (
 135       fun () ->
 136         while Q.is_empty q do Cond.wait q_cond q_lock done;
 137         q_discard := false;
 138         Q.pop q
 139     ) in
 140
 141   debug "slave processing command %s ..." (string_of_message cmd);
 142
 143   (try
 144      GtkThread.async !busy_hook ();
 145      execute_command cmd
 146    with exn ->
 147      (* If the user provided an override ?fail parameter to the
 148         original call, call that, else call the global hook.  *)
 149      match fail with
 150      | Some cb -> GtkThread.async cb exn
 151      | None -> GtkThread.async !failure_hook exn
 152   );
 153
 154   (* If there are no more commands in the queue, run the idle hook. *)
 155   let empty = with_lock q_lock (fun () -> Q.is_empty q) in
 156   if empty then GtkThread.async !idle_hook ();
 157
 158   if !quit then Thread.exit ();
 159   loop ()
 160
 161 and execute_command = function
 162   | Exit_thread ->
 163     quit := true;
 164     close_all ()
 165
 166   | Open_images (images, cb) as cmd ->
 167     status "Opening disk images ...";
 168
 169     open_disk_images images cb cmd
 170
 171 (* Close all handles. *)
 172 and close_all () =
 173 (*
 174   (match !conn with Some conn -> C.close conn | None -> ());
 175   conn := None;
 176 *)
 177   close_g ()
 178
 179 and close_g () =
 180   (match !g with Some g -> g#close () | None -> ());
 181   g := None
 182
 183 (* The common code for Open_domain and Open_images which opens the
 184  * libguestfs handle, adds the disks, and launches the appliance.
 185  *)
 186 and open_disk_images images cb cmd =
 187   debug "opening disk image %s" (string_of_images images);
 188
 189   close_g ();
 190   let g' = new G.guestfs () in
 191   g := Some g';
 192   let g = g' in
 193
 194   g#set_trace (trace ());
 195
 196   (* Attach progress bar callback. *)
 197   ignore (
 198     g#set_event_callback (
 199       fun g event handle buf array ->
 200         if event == G.EVENT_PROGRESS && Array.length array >= 4 then (
 201           let proc_nr = array.(0)
 202           and serial = array.(1)
 203           and position = array.(2)
 204           and total = array.(3) in
 205           debug "progress callback proc_nr=%Ld serial=%Ld posn=%Ld total=%Ld"
 206             proc_nr serial position total;
 207           GtkThread.async !progress_hook (position, total)
 208         )
 209     ) [ G.EVENT_PROGRESS ]
 210   );
 211
 212   List.iter (
 213     function
 214     | filename, None ->
 215         g#add_drive_opts ~readonly:true filename
 216     | filename, Some format ->
 217         g#add_drive_opts ~readonly:true ~format filename
 218   ) images;
 219
 220   g#launch ();
 221
 222   status "Listing filesystems ...";
 223
 224   (* Get list of filesystems. *)
 225   let fses = g#list_filesystems () in
 226
 227   status "Looking for operating systems ...";
 228
 229   (* Perform inspection.  This can fail, ignore errors. *)
 230   let roots =
 231     try Array.to_list (g#inspect_os ())
 232     with
 233       G.Error msg ->
 234         debug "inspection failed (error ignored): %s" msg;
 235         [] in
 236
 237   let oses = List.map (
 238     fun root ->
 239       let typ = g#inspect_get_type root in
 240       let windows_current_control_set =
 241         if typ <> "windows" then None
 242         else (
 243           try Some (g#inspect_get_windows_current_control_set root)
 244           with G.Error _ -> None
 245         ) in
 246       let windows_systemroot =
 247         if typ <> "windows" then None
 248         else (
 249           try Some (g#inspect_get_windows_systemroot root)
 250           with G.Error _ -> None
 251         ) in
 252
 253       {
 254         insp_root = root;
 255         insp_arch = g#inspect_get_arch root;
 256         insp_distro = g#inspect_get_distro root;
 257         insp_drive_mappings = g#inspect_get_drive_mappings root;
 258         insp_filesystems = g#inspect_get_filesystems root;
 259         insp_hostname = g#inspect_get_hostname root;
 260         insp_major_version = g#inspect_get_major_version root;
 261         insp_minor_version = g#inspect_get_minor_version root;
 262         insp_mountpoints = g#inspect_get_mountpoints root;
 263         insp_package_format = g#inspect_get_package_format root;
 264         insp_package_management = g#inspect_get_package_management root;
 265         insp_product_name = g#inspect_get_product_name root;
 266         insp_product_variant = g#inspect_get_product_variant root;
 267         insp_type = typ;
 268         insp_windows_current_control_set = windows_current_control_set;
 269         insp_windows_systemroot = windows_systemroot;
 270       }
 271   ) roots in
 272
 273   let data = {
 274     insp_all_filesystems = fses;
 275     insp_oses = oses;
 276   } in
 277
 278   status "Finished opening disk";
 279
 280   callback_if_not_discarded cb data
 281
 282 (*----------------------------------------------------------------------*)
 283 (* Start up one slave thread when the program starts. *)
 284 let slave_thread = Thread.create loop ()
 285
 286 let exit_thread () =
 287   discard_command_queue ();
 288   send_message Exit_thread;
 289   Thread.join slave_thread