slave.ml

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