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