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