X-Git-Url: http://git.annexia.org/?p=guestfs-browser.git;a=blobdiff_plain;f=slave.ml;h=dd087ddd61c17979eafaf4402473a71c09b79b47;hp=01105ef8700c143eadb89f83c684a3ccadb0f8f4;hb=23a1eac79ffcbab1801b89430fc0354e44cf7599;hpb=f09bb82de01019f24411cac2916d9567b5e9a235 diff --git a/slave.ml b/slave.ml index 01105ef..dd087dd 100644 --- a/slave.ml +++ b/slave.ml @@ -1,5 +1,5 @@ (* Guestfs Browser. - * Copyright (C) 2010 Red Hat Inc. + * Copyright (C) 2010-2015 Red Hat Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -18,11 +18,12 @@ open ExtList open ExtString -open CamomileLibrary -open Default.Camomile open Utils +open Slave_types +open Slave_utils + open Printf module C = Libvirt.Connect @@ -31,65 +32,34 @@ module D = Libvirt.Domain module G = Guestfs module M = Mutex module Q = Queue +module UTF8 = CamomileLibraryDefault.Camomile.UTF8 + type 'a callback = 'a -> unit (* The commands. *) type command = | Exit_thread + | Checksum_file of source * string * string * string callback | Connect of string option * domain list callback | Disk_usage of source * string * int64 callback | Download_dir_find0 of source * string * string * unit callback | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback - | Download_file of source * string * string * unit callback + | Download_file of source * string * string * bool * unit callback + | File_information of source * string * string callback + | File_xattrs of source * string * G.xattr array callback + | List_applications of inspection_os * G.application array callback | Open_domain of string * inspection_data callback | Open_images of (string * string option) list * inspection_data callback | Read_directory of source * string * direntry list callback - -and domain = { - dom_id : int; - dom_name : string; - dom_state : D.state; -} - -and inspection_data = { - insp_all_filesystems : (string * string) list; - insp_oses : inspection_os list; -} - -and inspection_os = { - insp_root : string; - insp_arch : string; - insp_distro : string; - insp_filesystems : string array; - insp_hostname : string; - insp_major_version : int; - insp_minor_version : int; - insp_mountpoints : (string * string) list; - insp_package_format : string; - insp_package_management : string; - insp_product_name : string; - insp_type : string; - insp_windows_systemroot : string option; - insp_winreg_DEFAULT : string option; - insp_winreg_SAM : string option; - insp_winreg_SECURITY : string option; - insp_winreg_SOFTWARE : string option; - insp_winreg_SYSTEM : string option; -} - -and source = OS of inspection_os | Volume of string - -and direntry = { - dent_name : string; - dent_stat : G.stat; - dent_link : string; -} - -and download_dir_tarball_format = Tar | TGZ | TXZ + | Reopen of inspection_data callback + | Run_command of string * unit callback let rec string_of_command = function | Exit_thread -> "Exit_thread" + | Checksum_file (src, pathname, csumtype, _) -> + sprintf "Checksum_file (%s, %s, %s)" + (string_of_source src) pathname csumtype | Connect (Some name, _) -> sprintf "Connect %s" name | Connect (None, _) -> "Connect NULL" | Disk_usage (src, remotedir, _) -> @@ -101,14 +71,24 @@ let rec string_of_command = function sprintf "Download_dir_tarball (%s, %s, %s, %s)" (string_of_source src) remotedir (string_of_download_dir_tarball_format format) localfile - | Download_file (src, remotefile, localfile, _) -> - sprintf "Download_file (%s, %s, %s)" - (string_of_source src) remotefile localfile + | Download_file (src, remotefile, localfile, check, _) -> + sprintf "Download_file (%s, %s, %s, %b)" + (string_of_source src) remotefile localfile check + | File_information (src, pathname, _) -> + sprintf "File_information (%s, %s)" (string_of_source src) pathname + | File_xattrs (src, pathname, _) -> + sprintf "File_xattrs (%s, %s)" (string_of_source src) pathname + | List_applications (os, _) -> + sprintf "List_applications %s" os.insp_root | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> sprintf "Open_images %s" (string_of_images images) | Read_directory (src, dir, _) -> sprintf "Read_directory (%s, %s)" (string_of_source src) dir + | Reopen _ -> + "Reopen" + | Run_command (cmd, _) -> + sprintf "Run_command %s" cmd and string_of_images images = "[" ^ @@ -178,6 +158,8 @@ let discard_command_queue () = q_discard := true ) +let checksum_file ?fail src pathname csumtype cb = + send_to_slave ?fail (Checksum_file (src, pathname, csumtype, cb)) let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb)) let disk_usage ?fail src remotedir cb = send_to_slave ?fail (Disk_usage (src, remotedir, cb)) @@ -187,11 +169,23 @@ let download_dir_tarball ?fail src remotedir format localfile cb = send_to_slave ?fail (Download_dir_tarball (src, remotedir, format, localfile, cb)) let download_file ?fail src remotefile localfile cb = - send_to_slave ?fail (Download_file (src, remotefile, localfile, cb)) + send_to_slave ?fail (Download_file (src, remotefile, localfile, false, cb)) +let download_file_if_not_exist ?fail src remotefile localfile cb = + send_to_slave ?fail (Download_file (src, remotefile, localfile, true, cb)) +let file_information ?fail src pathname cb = + send_to_slave ?fail (File_information (src, pathname, cb)) +let file_xattrs ?fail src pathname cb = + send_to_slave ?fail (File_xattrs (src, pathname, cb)) +let list_applications ?fail os cb = + send_to_slave ?fail (List_applications (os, cb)) let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb)) let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb)) let read_directory ?fail src path cb = send_to_slave ?fail (Read_directory (src, path, cb)) +let reopen ?fail cb = + send_to_slave ?fail (Reopen cb) +let run_command ?fail cmd cb = + send_to_slave ?fail (Run_command (cmd, cb)) (*----- Slave thread starts here -----*) @@ -204,6 +198,11 @@ let quit = ref false let conn = ref None let g = ref None +(* Last Open_domain or Open_images command. This is so we can implement + * the Reopen command. + *) +let last_open = ref None + (* Run the callback unless someone set the q_discard flag while * we were running the command. *) @@ -212,27 +211,6 @@ let callback_if_not_discarded (cb : 'a callback) (arg : 'a) = if not discard then GtkThread.async cb arg -(* Call 'f ()' with source mounted read-only. Ensure that everything - * is unmounted even if an exception is thrown. - *) -let with_mount_ro g src (f : unit -> 'a) : 'a = - Std.finally (fun () -> g#umount_all ()) ( - fun () -> - (* Do the mount - could be OS or single volume. *) - (match src with - | Volume dev -> g#mount_ro dev "/"; - | OS { insp_mountpoints = mps } -> - (* Sort the mountpoint keys by length, shortest first. *) - let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in - let mps = List.sort ~cmp mps in - (* Mount the filesystems. *) - List.iter ( - fun (mp, dev) -> g#mount_ro dev mp - ) mps - ); - f () - ) () - (* Update the status bar. *) let status fs = let f str = GtkThread.async !status_hook str in @@ -276,6 +254,19 @@ and execute_command = function quit := true; close_all () + | Checksum_file (src, pathname, csumtype, cb) -> + status "Calculating %s checksum of %s ..." csumtype pathname; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#checksum csumtype pathname + ) in + + status "Finished calculating %s checksum of %s" csumtype pathname; + callback_if_not_discarded cb r + | Connect (name, cb) -> let printable_name = match name with None -> "default hypervisor" | Some uri -> uri in @@ -328,7 +319,7 @@ and execute_command = function let g = get_g () in let f = match format with - | Tar -> g#tar_out + | Tar -> fun a b -> g#tar_out a b | TGZ -> g#tgz_out | TXZ -> g#txz_out in @@ -340,31 +331,72 @@ and execute_command = function status "Finished downloading %s" localfile; callback_if_not_discarded cb () - | Download_file (src, remotefile, localfile, cb) -> - status "Downloading %s to %s ..." remotefile localfile; + | Download_file (src, remotefile, localfile, check, cb) -> + if not check || not (local_file_exists localfile) then ( + status "Downloading %s to %s ..." remotefile localfile; - let g = get_g () in - with_mount_ro g src ( - fun () -> - g#download remotefile localfile - ); + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#download remotefile localfile + ); - status "Finished downloading %s" localfile; + status "Finished downloading %s" localfile + ); callback_if_not_discarded cb () - | Open_domain (name, cb) -> + | File_information (src, pathname, cb) -> + status "Calculating file information for %s ..." pathname; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#file pathname + ) in + + status "Finished calculating file information for %s" pathname; + callback_if_not_discarded cb r + + | File_xattrs (src, pathname, cb) -> + status "Getting file xattrs for %s ..." pathname; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#getxattrs pathname + ) in + + status "Finished calculating file information for %s" pathname; + callback_if_not_discarded cb r + + | List_applications (os, cb) -> + status "Listing applications ..."; + + let g = get_g () in + let r = + with_mount_ro g (OS os) ( + fun () -> + g#inspect_list_applications os.insp_root + ) in + + status "Finished listing applications"; + callback_if_not_discarded cb r + + | Open_domain (name, cb) as cmd -> status "Opening %s ..." name; let conn = get_conn () in let dom = D.lookup_by_name conn name in let xml = D.get_xml_desc dom in let images = get_disk_images_from_xml xml in - open_disk_images images cb + open_disk_images images cb cmd - | Open_images (images, cb) -> + | Open_images (images, cb) as cmd -> status "Opening disk images ..."; - open_disk_images images cb + open_disk_images images cb cmd | Read_directory (src, dir, cb) -> status "Reading directory %s ..." dir; @@ -374,10 +406,9 @@ and execute_command = function with_mount_ro g src ( fun () -> let names = g#ls dir in (* sorted and without . and .. *) - let names = Array.to_list names in - let stats = lstatlist_wrapper g dir names in - let links = readlink_wrapper g dir names stats in - names, stats, links + let stats = lstatlist g dir names in + let links = readlinks g dir names (Array.of_list stats) in + Array.to_list names, stats, links ) in assert ( let n = List.length names in @@ -392,6 +423,32 @@ and execute_command = function status "Finished reading directory %s" dir; callback_if_not_discarded cb entries + | Reopen cb -> + (* Execute the last_open command, if there was one. But note + * that we have to replace the callback in the saved command with + * the new callback passed by the main thread to reopen. + *) + (match !last_open with + | Some (Open_domain (name, _)) -> + execute_command (Open_domain (name, cb)) + | Some (Open_images (images, _)) -> + execute_command (Open_images (images, cb)) + | None -> + () (* invalid_arg? *) + | _ -> + assert false (* should never happen *) + ) + + | Run_command (cmd, cb) -> + status "Running %s ..." cmd; + + if Sys.command cmd <> 0 then + failwith "External command failed: %s" cmd; + + status "Finished %s ..." cmd; + + callback_if_not_discarded cb () + (* Expect to be connected, and return the current libvirt connection. *) and get_conn () = match !conn with @@ -407,6 +464,7 @@ and get_g () = and close_all () = (match !conn with Some conn -> C.close conn | None -> ()); conn := None; + last_open := None; close_g () and close_g () = @@ -474,7 +532,7 @@ and get_disk_images_from_xml xml = (* The common code for Open_domain and Open_images which opens the * libguestfs handle, adds the disks, and launches the appliance. *) -and open_disk_images images cb = +and open_disk_images images cb cmd = debug "opening disk image %s" (string_of_images images); close_g (); @@ -493,11 +551,19 @@ and open_disk_images images cb = (* g#set_verbose (verbose ());*) (* Attach progress bar callback. *) - g#set_progress_callback ( - fun proc_nr serial position total -> - debug "progress callback proc_nr=%d serial=%d posn=%Ld total=%Ld" - proc_nr serial position total; - GtkThread.async !progress_hook (position, total) + ignore ( + g#set_event_callback ( + fun event handle buf array -> + if event == G.EVENT_PROGRESS && Array.length array >= 4 then ( + let proc_nr = array.(0) + and serial = array.(1) + and position = array.(2) + and total = array.(3) in + debug "progress callback proc_nr=%Ld serial=%Ld posn=%Ld total=%Ld" + proc_nr serial position total; + GtkThread.async !progress_hook (position, total) + ) + ) [ G.EVENT_PROGRESS ] ); List.iter ( @@ -528,6 +594,12 @@ and open_disk_images images cb = let oses = List.map ( fun root -> let typ = g#inspect_get_type root in + let windows_current_control_set = + if typ <> "windows" then None + else ( + try Some (g#inspect_get_windows_current_control_set root) + with G.Error _ -> None + ) in let windows_systemroot = if typ <> "windows" then None else ( @@ -543,6 +615,7 @@ and open_disk_images images cb = insp_root = root; insp_arch = g#inspect_get_arch root; insp_distro = g#inspect_get_distro root; + insp_drive_mappings = g#inspect_get_drive_mappings root; insp_filesystems = g#inspect_get_filesystems root; insp_hostname = g#inspect_get_hostname root; insp_major_version = g#inspect_get_major_version root; @@ -551,7 +624,9 @@ and open_disk_images images cb = insp_package_format = g#inspect_get_package_format root; insp_package_management = g#inspect_get_package_management root; insp_product_name = g#inspect_get_product_name root; + insp_product_variant = g#inspect_get_product_variant root; insp_type = typ; + insp_windows_current_control_set = windows_current_control_set; insp_windows_systemroot = windows_systemroot; insp_winreg_DEFAULT = None; (* incomplete, see below *) insp_winreg_SAM = None; @@ -598,136 +673,11 @@ and open_disk_images images cb = } in status "Finished opening disk"; - callback_if_not_discarded cb data -(* guestfs_lstatlist has a "hidden" limit of the protocol message size. - * Call this function, but split the list of names into chunks. - *) -and lstatlist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#lstatlist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ lstatlist_wrapper g dir names - -(* For each entry which is a symlink, read the destination of the - * symlink. This is non-trivial because on Windows we cannot use - * readlink but need to instead parse the reparse data from NTFS. - *) -and readlink_wrapper g dir names stats = - (* Is the directory on an NTFS filesystem? *) - let dev = get_mounted_device g dir in - if g#vfs_type dev <> "ntfs" then ( - (* Not NTFS, use the fast g#readlinklist method. *) - let rec readlinklist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#readlinklist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ readlinklist_wrapper g dir names - in - readlinklist_wrapper g dir names - ) - else ( - (* NTFS: look up each symlink individually. *) - List.map ( - fun (name, stat) -> - if not (is_symlink stat.G.mode) then "" - else - let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in - try - let _, display = get_ntfs_reparse_data g path in - display - with exn -> - debug "get_ntfs_reparse_data: %s: failed: %s" - path (Printexc.to_string exn); - "?" - ) (List.combine names stats) - ) + (* Save the command, in case user does Reopen. *) + last_open := Some cmd; -(* See: - * https://bugzilla.redhat.com/show_bug.cgi?id=663407 - * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2 - * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/ - * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/ - * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx - *) -and get_ntfs_reparse_data g path = - let data = g#lgetxattr path "system.ntfs_reparse_data" in - let link, display = - bitmatch Bitstring.bitstring_of_string data with - (* IO_REPARSE_TAG_MOUNT_POINT *) - | { 0xa0000003_l : 32 : littleendian; - _ : 16 : littleendian; (* data length - ignore it *) - _ : 16 : littleendian; (* reserved *) - link_offset : 16 : littleendian; - link_len : 16 : littleendian; - display_offset : 16 : littleendian; - display_len : 16 : littleendian; - link : link_len * 8 : - string, offset (8 * (link_offset + 0x10)); - display : display_len * 8 : - string, offset (8 * (display_offset + 0x10)) } -> - (* These strings should always be valid UTF16LE, but the caller - * is prepared to catch any exception if this fails. - *) - let link = windows_string_to_utf8 link in - let display = windows_string_to_utf8 display in - link, display - | { 0xa0000003_l : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path - ) - - (* IO_REPARSE_TAG_SYMLINK *) - | { 0xa000000c_l : 32 : littleendian; - _ : 16 : littleendian; (* data length - ignore it *) - _ : 16 : littleendian; (* reserved *) - link_offset : 16 : littleendian; - link_len : 16 : littleendian; - display_offset : 16 : littleendian; - display_len : 16 : littleendian; - link : link_len * 8 : - string, offset (8 * (link_offset + 0x14)); - display : display_len * 8 : - string, offset (8 * (display_offset + 0x14)) } -> - let link = windows_string_to_utf8 link in - let display = windows_string_to_utf8 display in - link, display - | { 0xa000000c_l : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path - ) - - | { i : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: reparse data of type 0x%lx is not supported" path i - ) - | { _ } -> - invalid_arg (sprintf "%s: reparse data is too short" path) in - - link, display - -(* Given a path which is located somewhere on a mountpoint, return the - * device name. This works by using g#mountpoints and then looking for - * the mount path with the longest match. - *) -and get_mounted_device g path = - let mps = g#mountpoints () in - let mps = List.map ( - fun (dev, mp) -> - if String.starts_with path mp then dev, String.length mp else dev, 0 - ) mps in - let cmp (_,n1) (_,n2) = compare n2 n1 in - let mps = List.sort ~cmp mps in - match mps with - | [] -> - invalid_arg (sprintf "%s: not mounted" path) - | (_,0) :: _ -> - invalid_arg (sprintf "%s: not found on any filesystem" path) - | (dev,_) :: _ -> dev + callback_if_not_discarded cb data (* Start up one slave thread. *) let slave_thread = Thread.create loop ()