slave.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 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 ExtList
  20 open Printf
  21 open Utils
  22
  23 module C = Libvirt.Connect
  24 module Cond = Condition
  25 module D = Libvirt.Domain
  26 module M = Mutex
  27 module Q = Queue
  28
  29 type 'a callback = 'a -> unit
  30
  31 (* The commands. *)
  32 type command =
  33   | Exit_thread
  34   | Connect of string option * domain list callback
  35   | Disk_usage of source * string * int64 callback
  36   | Download_dir_find0 of source * string * string * unit callback
  37   | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback
  38   | Download_file of source * string * string * unit callback
  39   | Open_domain of string * inspection_data callback
  40   | Open_images of (string * string option) list * inspection_data callback
  41   | Read_directory of source * string * direntry list callback
  42
  43 and domain = {
  44   dom_id : int;
  45   dom_name : string;
  46   dom_state : D.state;
  47 }
  48
  49 and inspection_data = {
  50   insp_all_filesystems : (string * string) list;
  51   insp_oses : inspection_os list;
  52 }
  53
  54 and inspection_os = {
  55   insp_root : string;
  56   insp_arch : string;
  57   insp_distro : string;
  58   insp_filesystems : string array;
  59   insp_hostname : string;
  60   insp_major_version : int;
  61   insp_minor_version : int;
  62   insp_mountpoints : (string * string) list;
  63   insp_package_format : string;
  64   insp_package_management : string;
  65   insp_product_name : string;
  66   insp_type : string;
  67   insp_windows_systemroot : string option;
  68 }
  69
  70 and source = OS of inspection_os | Volume of string
  71
  72 and direntry = {
  73   dent_name : string;
  74   dent_stat : Guestfs.stat;
  75   dent_link : string;
  76 }
  77
  78 and download_dir_tarball_format = Tar | TGZ | TXZ
  79
  80 let rec string_of_command = function
  81   | Exit_thread -> "Exit_thread"
  82   | Connect (Some name, _) -> sprintf "Connect %s" name
  83   | Connect (None, _) -> "Connect NULL"
  84   | Disk_usage (src, remotedir, _) ->
  85       sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir
  86   | Download_dir_find0 (src, remotedir, localfile, _) ->
  87       sprintf "Download_dir_find0 (%s, %s, %s)"
  88         (string_of_source src) remotedir localfile
  89   | Download_dir_tarball (src, remotedir, format, localfile, _) ->
  90       sprintf "Download_dir_tarball (%s, %s, %s, %s)"
  91         (string_of_source src) remotedir
  92         (string_of_download_dir_tarball_format format) localfile
  93   | Download_file (src, remotefile, localfile, _) ->
  94       sprintf "Download_file (%s, %s, %s)"
  95         (string_of_source src) remotefile localfile
  96   | Open_domain (name, _) -> sprintf "Open_domain %s" name
  97   | Open_images (images, _) ->
  98       sprintf "Open_images %s" (string_of_images images)
  99   | Read_directory (src, dir, _) ->
 100       sprintf "Read_directory (%s, %s)" (string_of_source src) dir
 101
 102 and string_of_images images =
 103   "[" ^
 104     String.concat "; "
 105     (List.map (function
 106                | fn, None -> fn
 107                | fn, Some format -> sprintf "%s (%s)" fn format)
 108        images) ^ "]"
 109
 110 and string_of_source = function
 111   | OS { insp_root = root } ->
 112       sprintf "OS %s" root
 113   | Volume dev ->
 114       sprintf "Volume %s" dev
 115
 116 and string_of_download_dir_tarball_format = function
 117   | Tar -> "Tar"
 118   | TGZ -> "TGZ"
 119   | TXZ -> "TXZ"
 120
 121 let no_callback _ = ()
 122
 123 let failure_hook = ref (fun _ -> ())
 124 let busy_hook = ref (fun _ -> ())
 125 let idle_hook = ref (fun _ -> ())
 126 let status_hook = ref (fun _ -> ())
 127 let progress_hook = ref (fun _ -> ())
 128
 129 let set_failure_hook cb = failure_hook := cb
 130 let set_busy_hook cb = busy_hook := cb
 131 let set_idle_hook cb = idle_hook := cb
 132 let set_status_hook cb = status_hook := cb
 133 let set_progress_hook cb = progress_hook := cb
 134
 135 (* Execute a function, while holding a mutex.  If the function
 136  * fails, ensure we release the mutex before rethrowing the
 137  * exception.
 138  *)
 139 let with_lock m f =
 140   M.lock m;
 141   let r = try Left (f ()) with exn -> Right exn in
 142   M.unlock m;
 143   match r with
 144   | Left r -> r
 145   | Right exn -> raise exn
 146
 147 (* The queue of commands, and a lock and condition to protect it. *)
 148 let q = Q.create ()
 149 let q_discard = ref false
 150 let q_lock = M.create ()
 151 let q_cond = Cond.create ()
 152
 153 (* Send a command message to the slave thread. *)
 154 let send_to_slave ?fail cmd =
 155   debug "sending message %s to slave thread ..." (string_of_command cmd);
 156   with_lock q_lock (
 157     fun () ->
 158       Q.push (fail, cmd) q;
 159       Cond.signal q_cond
 160   )
 161
 162 let discard_command_queue () =
 163   with_lock q_lock (
 164     fun () ->
 165       Q.clear q;
 166       (* Discard the currently running command. *)
 167       q_discard := true
 168   )
 169
 170 let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb))
 171 let disk_usage ?fail src remotedir cb =
 172   send_to_slave ?fail (Disk_usage (src, remotedir, cb))
 173 let download_dir_find0 ?fail src remotedir localfile cb =
 174   send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb))
 175 let download_dir_tarball ?fail src remotedir format localfile cb =
 176   send_to_slave ?fail
 177     (Download_dir_tarball (src, remotedir, format, localfile, cb))
 178 let download_file ?fail src remotefile localfile cb =
 179   send_to_slave ?fail (Download_file (src, remotefile, localfile, cb))
 180 let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
 181 let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
 182 let read_directory ?fail src path cb =
 183   send_to_slave ?fail (Read_directory (src, path, cb))
 184
 185 (*----- Slave thread starts here -----*)
 186
 187 (* Set this to true to exit the thread. *)
 188 let quit = ref false
 189
 190 (* Handles.  These are not protected by locks because only the slave
 191  * thread has access to them.
 192  *)
 193 let conn = ref None
 194 let g = ref None
 195
 196 (* Run the callback unless someone set the q_discard flag while
 197  * we were running the command.
 198  *)
 199 let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
 200   let discard = with_lock q_lock (fun () -> !q_discard) in
 201   if not discard then
 202     GtkThread.async cb arg
 203
 204 (* Call 'f ()' with source mounted read-only.  Ensure that everything
 205  * is unmounted even if an exception is thrown.
 206  *)
 207 let with_mount_ro g src (f : unit -> 'a) : 'a =
 208   Std.finally (fun () -> g#umount_all ()) (
 209     fun () ->
 210       (* Do the mount - could be OS or single volume. *)
 211       (match src with
 212       | Volume dev -> g#mount_ro dev "/";
 213       | OS { insp_mountpoints = mps } ->
 214           (* Sort the mountpoint keys by length, shortest first. *)
 215           let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
 216           let mps = List.sort ~cmp mps in
 217           (* Mount the filesystems. *)
 218           List.iter (
 219             fun (mp, dev) -> g#mount_ro dev mp
 220           ) mps
 221       );
 222       f ()
 223   ) ()
 224
 225 (* Update the status bar. *)
 226 let status fs =
 227   let f str = GtkThread.async !status_hook str in
 228   ksprintf f fs
 229
 230 let rec loop () =
 231   debug "top of slave loop";
 232
 233   (* Get the next command. *)
 234   let fail, cmd =
 235     with_lock q_lock (
 236       fun () ->
 237         while Q.is_empty q do Cond.wait q_cond q_lock done;
 238         q_discard := false;
 239         Q.pop q
 240     ) in
 241
 242   debug "slave processing command %s ..." (string_of_command cmd);
 243
 244   (try
 245      GtkThread.async !busy_hook ();
 246      execute_command cmd
 247    with exn ->
 248      (* If the user provided an override ?fail parameter to the
 249       * original call, call that, else call the global hook.
 250       *)
 251      match fail with
 252      | Some cb -> GtkThread.async cb exn
 253      | None -> GtkThread.async !failure_hook exn
 254   );
 255
 256   (* If there are no more commands in the queue, run the idle hook. *)
 257   let empty = with_lock q_lock (fun () -> Q.is_empty q) in
 258   if empty then GtkThread.async !idle_hook ();
 259
 260   if !quit then Thread.exit ();
 261   loop ()
 262
 263 and execute_command = function
 264   | Exit_thread ->
 265       quit := true;
 266       close_all ()
 267
 268   | Connect (name, cb) ->
 269       let printable_name =
 270         match name with None -> "default hypervisor" | Some uri -> uri in
 271       status "Connecting to %s ..." printable_name;
 272
 273       close_all ();
 274       conn := Some (C.connect_readonly ?name ());
 275
 276       let conn = get_conn () in
 277       let doms = D.get_domains conn [D.ListAll] in
 278       let doms = List.map (
 279         fun d ->
 280           { dom_id = D.get_id d;
 281             dom_name = D.get_name d;
 282             dom_state = (D.get_info d).D.state }
 283       ) doms in
 284       let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
 285       let doms = List.sort ~cmp doms in
 286
 287       status "Connected to %s" printable_name;
 288       callback_if_not_discarded cb doms
 289
 290   | Disk_usage (src, remotedir, cb) ->
 291       status "Calculating disk usage of %s ..." remotedir;
 292
 293       let g = get_g () in
 294       let r =
 295         with_mount_ro g src (
 296           fun () ->
 297             g#du remotedir
 298         ) in
 299
 300       status "Finished calculating disk usage of %s" remotedir;
 301       callback_if_not_discarded cb r
 302
 303   | Download_dir_find0 (src, remotedir, localfile, cb) ->
 304       status "Downloading %s filenames to %s ..." remotedir localfile;
 305
 306       let g = get_g () in
 307       with_mount_ro g src (
 308         fun () ->
 309           g#find0 remotedir localfile
 310       );
 311
 312       status "Finished downloading %s" localfile;
 313       callback_if_not_discarded cb ()
 314
 315   | Download_dir_tarball (src, remotedir, format, localfile, cb) ->
 316       status "Downloading %s to %s ..." remotedir localfile;
 317
 318       let g = get_g () in
 319       let f = match format with
 320         | Tar -> g#tar_out
 321         | TGZ -> g#tgz_out
 322         | TXZ -> g#txz_out
 323       in
 324       with_mount_ro g src (
 325         fun () ->
 326           f remotedir localfile
 327       );
 328
 329       status "Finished downloading %s" localfile;
 330       callback_if_not_discarded cb ()
 331
 332   | Download_file (src, remotefile, localfile, cb) ->
 333       status "Downloading %s to %s ..." remotefile localfile;
 334
 335       let g = get_g () in
 336       with_mount_ro g src (
 337         fun () ->
 338           g#download remotefile localfile
 339       );
 340
 341       status "Finished downloading %s" localfile;
 342       callback_if_not_discarded cb ()
 343
 344   | Open_domain (name, cb) ->
 345       status "Opening %s ..." name;
 346
 347       let conn = get_conn () in
 348       let dom = D.lookup_by_name conn name in
 349       let xml = D.get_xml_desc dom in
 350       let images = get_disk_images_from_xml xml in
 351       open_disk_images images cb
 352
 353   | Open_images (images, cb) ->
 354       status "Opening disk images ...";
 355
 356       open_disk_images images cb
 357
 358   | Read_directory (src, dir, cb) ->
 359       status "Reading directory %s ..." dir;
 360
 361       let g = get_g () in
 362       let names, stats, links =
 363         with_mount_ro g src (
 364           fun () ->
 365             let names = g#ls dir in (* sorted and without . and .. *)
 366             let names = Array.to_list names in
 367             let stats = lstatlist_wrapper g dir names in
 368             let links = readlinklist_wrapper g dir names in
 369             names, stats, links
 370         ) in
 371       assert (
 372         let n = List.length names in
 373         n = List.length stats && n = List.length links
 374       );
 375       let entries = List.combine (List.combine names stats) links in
 376       let entries = List.map (
 377         fun ((name, stat), link) ->
 378           { dent_name = name; dent_stat = stat; dent_link = link }
 379       ) entries in
 380
 381       status "Finished reading directory %s" dir;
 382       callback_if_not_discarded cb entries
 383
 384 (* Expect to be connected, and return the current libvirt connection. *)
 385 and get_conn () =
 386   match !conn with
 387   | Some conn -> conn
 388   | None -> failwith "not connected to libvirt"
 389
 390 and get_g () =
 391   match !g with
 392   | Some g -> g
 393   | None -> failwith "no domain or disk image is open"
 394
 395 (* Close all libvirt and libguestfs handles. *)
 396 and close_all () =
 397   (match !conn with Some conn -> C.close conn | None -> ());
 398   conn := None;
 399   close_g ()
 400
 401 and close_g () =
 402   (match !g with Some g -> g#close () | None -> ());
 403   g := None
 404
 405 and get_disk_images_from_xml xml =
 406   let xml = Xml.parse_string xml in
 407
 408   (* Return the device nodes. *)
 409   let devices =
 410     match xml with
 411     | Xml.Element ("domain", _, children) ->
 412         let devices =
 413           List.filter_map (
 414             function
 415             | Xml.Element ("devices", _, devices) -> Some devices
 416             | _ -> None
 417           ) children in
 418         List.concat devices
 419     | _ ->
 420         failwith "get_xml_desc didn't return <domain/>" in
 421
 422   (* Look for <source attr_name=attr_val/> and return attr_val. *)
 423   let rec source_of attr_name = function
 424     | [] -> None
 425     | Xml.Element ("source", attrs, _) :: rest ->
 426         (try Some (List.assoc attr_name attrs)
 427          with Not_found -> source_of attr_name rest)
 428     | _ :: rest -> source_of attr_name rest
 429   in
 430
 431   (* Look for <driver type=attr_val/> and return attr_val. *)
 432   let rec format_of = function
 433     | [] -> None
 434     | Xml.Element ("driver", attrs, _) :: rest ->
 435         (try Some (List.assoc "type" attrs)
 436          with Not_found -> format_of rest)
 437     | _ :: rest -> format_of rest
 438   in
 439
 440   (* Look for <disk> nodes and return the sources (block devices) of those. *)
 441   let blkdevs =
 442     List.filter_map (
 443       function
 444       | Xml.Element ("disk", attrs, disks) ->
 445           let filename =
 446             try
 447               let typ = List.assoc "type" attrs in
 448               if typ = "file" then source_of "file" disks
 449               else if typ = "block" then source_of "dev" disks
 450               else None
 451             with
 452               Not_found -> None in
 453           (match filename with
 454            | None -> None
 455            | Some filename ->
 456                let format = format_of disks in
 457                Some (filename, format)
 458           );
 459       | _ -> None
 460     ) devices in
 461   blkdevs
 462
 463 (* The common code for Open_domain and Open_images which opens the
 464  * libguestfs handle, adds the disks, and launches the appliance.
 465  *)
 466 and open_disk_images images cb =
 467   debug "opening disk image %s" (string_of_images images);
 468
 469   close_g ();
 470   let g' = new Guestfs.guestfs () in
 471   g := Some g';
 472   let g = g' in
 473
 474   g#set_trace (trace ());
 475
 476   (* Uncomment the next line to pass the verbose flag from the command
 477    * line through to libguestfs.  This is not generally necessary since
 478    * we are not so interested in debugging libguestfs problems at this
 479    * level, and the user can always set LIBGUESTFS_DEBUG=1 if they need
 480    * to.
 481    *)
 482   (* g#set_verbose (verbose ());*)
 483
 484   (* Attach progress bar callback. *)
 485   g#set_progress_callback (
 486     fun proc_nr serial position total ->
 487       debug "progress callback proc_nr=%d serial=%d posn=%Ld total=%Ld"
 488         proc_nr serial position total;
 489       GtkThread.async !progress_hook (position, total)
 490   );
 491
 492   List.iter (
 493     function
 494     | filename, None ->
 495         g#add_drive_opts ~readonly:true filename
 496     | filename, Some format ->
 497         g#add_drive_opts ~readonly:true ~format filename
 498   ) images;
 499
 500   g#launch ();
 501
 502   status "Listing filesystems ...";
 503
 504   (* Get list of filesystems. *)
 505   let fses = g#list_filesystems () in
 506
 507   status "Looking for operating systems ...";
 508
 509   (* Perform inspection.  This can fail, ignore errors. *)
 510   let roots =
 511     try Array.to_list (g#inspect_os ())
 512     with
 513       Guestfs.Error msg ->
 514         debug "inspection failed (error ignored): %s" msg;
 515         [] in
 516
 517   let oses = List.map (
 518     fun root -> {
 519       insp_root = root;
 520       insp_arch = g#inspect_get_arch root;
 521       insp_distro = g#inspect_get_distro root;
 522       insp_filesystems = g#inspect_get_filesystems root;
 523       insp_hostname = g#inspect_get_hostname root;
 524       insp_major_version = g#inspect_get_major_version root;
 525       insp_minor_version = g#inspect_get_minor_version root;
 526       insp_mountpoints = g#inspect_get_mountpoints root;
 527       insp_package_format = g#inspect_get_package_format root;
 528       insp_package_management = g#inspect_get_package_management root;
 529       insp_product_name = g#inspect_get_product_name root;
 530       insp_type = g#inspect_get_type root;
 531       insp_windows_systemroot =
 532         try Some (g#inspect_get_windows_systemroot root)
 533         with Guestfs.Error _ -> None
 534     }
 535   ) roots in
 536   let data = {
 537     insp_all_filesystems = fses;
 538     insp_oses = oses;
 539   } in
 540
 541   status "Finished opening disk";
 542   callback_if_not_discarded cb data
 543
 544 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.
 545  * Call this function, but split the list of names into chunks.
 546  *)
 547 and lstatlist_wrapper g dir = function
 548   | [] -> []
 549   | names ->
 550       let names', names = List.take 1000 names, List.drop 1000 names in
 551       let xs = g#lstatlist dir (Array.of_list names') in
 552       let xs = Array.to_list xs in
 553       xs @ lstatlist_wrapper g dir names
 554
 555 (* Same as above for guestfs_readlinklist. *)
 556 and readlinklist_wrapper g dir = function
 557   | [] -> []
 558   | names ->
 559       let names', names = List.take 1000 names, List.drop 1000 names in
 560       let xs = g#readlinklist dir (Array.of_list names') in
 561       let xs = Array.to_list xs in
 562       xs @ readlinklist_wrapper g dir names
 563
 564 (* Start up one slave thread. *)
 565 let slave_thread = Thread.create loop ()
 566
 567 (* Note the following function is called from the main thread. *)
 568 let exit_thread () =
 569   discard_command_queue ();
 570   ignore (send_to_slave Exit_thread);
 571   Thread.join slave_thread