X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=slave.ml;h=01105ef8700c143eadb89f83c684a3ccadb0f8f4;hb=f09bb82de01019f24411cac2916d9567b5e9a235;hp=74ce2175280c829587057dc71f33506a4ce8ec07;hpb=73eef681e27803a1a7379be84ec74b17e02450fd;p=guestfs-browser.git diff --git a/slave.ml b/slave.ml index 74ce217..01105ef 100644 --- a/slave.ml +++ b/slave.ml @@ -17,12 +17,18 @@ *) open ExtList -open Printf +open ExtString +open CamomileLibrary +open Default.Camomile + open Utils +open Printf + module C = Libvirt.Connect module Cond = Condition module D = Libvirt.Domain +module G = Guestfs module M = Mutex module Q = Queue @@ -32,8 +38,12 @@ type 'a callback = 'a -> unit type command = | Exit_thread | 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 | Open_domain of string * inspection_data callback - | Open_images of string list * inspection_data callback + | Open_images of (string * string option) list * inspection_data callback | Read_directory of source * string * direntry list callback and domain = { @@ -61,37 +71,77 @@ and inspection_os = { 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 : Guestfs.stat; + dent_stat : G.stat; dent_link : string; } +and download_dir_tarball_format = Tar | TGZ | TXZ + let rec string_of_command = function | Exit_thread -> "Exit_thread" | Connect (Some name, _) -> sprintf "Connect %s" name | Connect (None, _) -> "Connect NULL" + | Disk_usage (src, remotedir, _) -> + sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir + | Download_dir_find0 (src, remotedir, localfile, _) -> + sprintf "Download_dir_find0 (%s, %s, %s)" + (string_of_source src) remotedir localfile + | Download_dir_tarball (src, remotedir, format, localfile, _) -> + 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 | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> - sprintf "Open_images [%s]" (String.concat "; " images) - | Read_directory (OS { insp_root = root }, dir, _) -> - sprintf "Read_directory (OS %s, %s)" root dir - | Read_directory (Volume dev, dir, _) -> - sprintf "Read_directory (Volume %s, %s)" dev dir + sprintf "Open_images %s" (string_of_images images) + | Read_directory (src, dir, _) -> + sprintf "Read_directory (%s, %s)" (string_of_source src) dir + +and string_of_images images = + "[" ^ + String.concat "; " + (List.map (function + | fn, None -> fn + | fn, Some format -> sprintf "%s (%s)" fn format) + images) ^ "]" + +and string_of_source = function + | OS { insp_root = root } -> + sprintf "OS %s" root + | Volume dev -> + sprintf "Volume %s" dev + +and string_of_download_dir_tarball_format = function + | Tar -> "Tar" + | TGZ -> "TGZ" + | TXZ -> "TXZ" let no_callback _ = () let failure_hook = ref (fun _ -> ()) let busy_hook = ref (fun _ -> ()) let idle_hook = ref (fun _ -> ()) +let status_hook = ref (fun _ -> ()) +let progress_hook = ref (fun _ -> ()) let set_failure_hook cb = failure_hook := cb let set_busy_hook cb = busy_hook := cb let set_idle_hook cb = idle_hook := cb +let set_status_hook cb = status_hook := cb +let set_progress_hook cb = progress_hook := cb (* Execute a function, while holding a mutex. If the function * fails, ensure we release the mutex before rethrowing the @@ -129,6 +179,15 @@ let discard_command_queue () = ) 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)) +let download_dir_find0 ?fail src remotedir localfile cb = + send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb)) +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)) 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 = @@ -174,6 +233,11 @@ let with_mount_ro g src (f : unit -> 'a) : 'a = f () ) () +(* Update the status bar. *) +let status fs = + let f str = GtkThread.async !status_hook str in + ksprintf f fs + let rec loop () = debug "top of slave loop"; @@ -213,6 +277,10 @@ and execute_command = function close_all () | Connect (name, cb) -> + let printable_name = + match name with None -> "default hypervisor" | Some uri -> uri in + status "Connecting to %s ..." printable_name; + close_all (); conn := Some (C.connect_readonly ?name ()); @@ -224,11 +292,69 @@ and execute_command = function dom_name = D.get_name d; dom_state = (D.get_info d).D.state } ) doms in - let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in + let cmp { dom_name = n1 } { dom_name = n2 } = UTF8.compare n1 n2 in let doms = List.sort ~cmp doms in + + status "Connected to %s" printable_name; callback_if_not_discarded cb doms + | Disk_usage (src, remotedir, cb) -> + status "Calculating disk usage of %s ..." remotedir; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#du remotedir + ) in + + status "Finished calculating disk usage of %s" remotedir; + callback_if_not_discarded cb r + + | Download_dir_find0 (src, remotedir, localfile, cb) -> + status "Downloading %s filenames to %s ..." remotedir localfile; + + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#find0 remotedir localfile + ); + + status "Finished downloading %s" localfile; + callback_if_not_discarded cb () + + | Download_dir_tarball (src, remotedir, format, localfile, cb) -> + status "Downloading %s to %s ..." remotedir localfile; + + let g = get_g () in + let f = match format with + | Tar -> g#tar_out + | TGZ -> g#tgz_out + | TXZ -> g#txz_out + in + with_mount_ro g src ( + fun () -> + f remotedir localfile + ); + + status "Finished downloading %s" localfile; + callback_if_not_discarded cb () + + | Download_file (src, remotefile, localfile, cb) -> + status "Downloading %s to %s ..." remotefile localfile; + + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#download remotefile localfile + ); + + status "Finished downloading %s" localfile; + callback_if_not_discarded cb () + | Open_domain (name, cb) -> + 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 @@ -236,9 +362,13 @@ and execute_command = function open_disk_images images cb | Open_images (images, cb) -> + status "Opening disk images ..."; + open_disk_images images cb | Read_directory (src, dir, cb) -> + status "Reading directory %s ..." dir; + let g = get_g () in let names, stats, links = with_mount_ro g src ( @@ -246,7 +376,7 @@ and execute_command = function 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 = readlinklist_wrapper g dir names in + let links = readlink_wrapper g dir names stats in names, stats, links ) in assert ( @@ -258,6 +388,8 @@ and execute_command = function fun ((name, stat), link) -> { dent_name = name; dent_stat = stat; dent_link = link } ) entries in + + status "Finished reading directory %s" dir; callback_if_not_discarded cb entries (* Expect to be connected, and return the current libvirt connection. *) @@ -307,18 +439,34 @@ and get_disk_images_from_xml xml = | _ :: rest -> source_of attr_name rest in + (* Look for and return attr_val. *) + let rec format_of = function + | [] -> None + | Xml.Element ("driver", attrs, _) :: rest -> + (try Some (List.assoc "type" attrs) + with Not_found -> format_of rest) + | _ :: rest -> format_of rest + in + (* Look for nodes and return the sources (block devices) of those. *) let blkdevs = List.filter_map ( function - | Xml.Element ("disk", attrs, children) -> - (try - let typ = List.assoc "type" attrs in - if typ = "file" then source_of "file" children - else if typ = "block" then source_of "dev" children - else None - with - Not_found -> None) + | Xml.Element ("disk", attrs, disks) -> + let filename = + try + let typ = List.assoc "type" attrs in + if typ = "file" then source_of "file" disks + else if typ = "block" then source_of "dev" disks + else None + with + Not_found -> None in + (match filename with + | None -> None + | Some filename -> + let format = format_of disks in + Some (filename, format) + ); | _ -> None ) devices in blkdevs @@ -327,13 +475,15 @@ and get_disk_images_from_xml xml = * libguestfs handle, adds the disks, and launches the appliance. *) and open_disk_images images cb = - debug "opening disk image [%s]" (String.concat "; " images); + debug "opening disk image %s" (string_of_images images); close_g (); - let g' = new Guestfs.guestfs () in + let g' = new G.guestfs () in g := Some g'; let g = g' in + g#set_trace (trace ()); + (* Uncomment the next line to pass the verbose flag from the command * line through to libguestfs. This is not generally necessary since * we are not so interested in debugging libguestfs problems at this @@ -342,44 +492,112 @@ and open_disk_images images cb = *) (* g#set_verbose (verbose ());*) - List.iter g#add_drive_ro images; + (* 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) + ); + + List.iter ( + function + | filename, None -> + g#add_drive_opts ~readonly:true filename + | filename, Some format -> + g#add_drive_opts ~readonly:true ~format filename + ) images; g#launch (); + status "Listing filesystems ..."; + (* Get list of filesystems. *) let fses = g#list_filesystems () in + status "Looking for operating systems ..."; + (* Perform inspection. This can fail, ignore errors. *) let roots = try Array.to_list (g#inspect_os ()) with - Guestfs.Error msg -> + G.Error msg -> debug "inspection failed (error ignored): %s" msg; [] in let oses = List.map ( - fun root -> { - insp_root = root; - insp_arch = g#inspect_get_arch root; - insp_distro = g#inspect_get_distro root; - insp_filesystems = g#inspect_get_filesystems root; - insp_hostname = g#inspect_get_hostname root; - insp_major_version = g#inspect_get_major_version root; - insp_minor_version = g#inspect_get_minor_version root; - insp_mountpoints = g#inspect_get_mountpoints root; - 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_type = g#inspect_get_type root; - insp_windows_systemroot = - try Some (g#inspect_get_windows_systemroot root) - with Guestfs.Error _ -> None - } + fun root -> + let typ = g#inspect_get_type root in + let windows_systemroot = + if typ <> "windows" then None + else ( + try Some (g#inspect_get_windows_systemroot root) + with G.Error _ -> None + ) in + + (* Create most of the OS object that we're going to return. We + * have to pass this to with_mount_ro below which is why we need + * to partially create it here. + *) + let os = { + insp_root = root; + insp_arch = g#inspect_get_arch root; + insp_distro = g#inspect_get_distro root; + insp_filesystems = g#inspect_get_filesystems root; + insp_hostname = g#inspect_get_hostname root; + insp_major_version = g#inspect_get_major_version root; + insp_minor_version = g#inspect_get_minor_version root; + insp_mountpoints = g#inspect_get_mountpoints root; + 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_type = typ; + insp_windows_systemroot = windows_systemroot; + insp_winreg_DEFAULT = None; (* incomplete, see below *) + insp_winreg_SAM = None; + insp_winreg_SECURITY = None; + insp_winreg_SOFTWARE = None; + insp_winreg_SYSTEM = None; + } in + + (* We need to mount the root in order to look for Registry hives. *) + let winreg_DEFAULT, winreg_SAM, winreg_SECURITY, winreg_SOFTWARE, + winreg_SYSTEM = + match windows_systemroot with + | None -> None, None, None, None, None + | Some sysroot -> + with_mount_ro g (OS os) ( + fun () -> + let check_for_hive filename = + let path = + sprintf "%s/system32/config/%s" sysroot filename in + try Some (g#case_sensitive_path path) + with G.Error _ -> None + in + check_for_hive "default", + check_for_hive "sam", + check_for_hive "security", + check_for_hive "software", + check_for_hive "system" + ) in + + (* Fill in the remaining struct fields. *) + let os = { os with + insp_winreg_DEFAULT = winreg_DEFAULT; + insp_winreg_SAM = winreg_SAM; + insp_winreg_SECURITY = winreg_SECURITY; + insp_winreg_SOFTWARE = winreg_SOFTWARE; + insp_winreg_SYSTEM = winreg_SYSTEM + } in + os ) roots in + let data = { insp_all_filesystems = fses; insp_oses = oses; } in + + status "Finished opening disk"; callback_if_not_discarded cb data (* guestfs_lstatlist has a "hidden" limit of the protocol message size. @@ -393,14 +611,123 @@ and lstatlist_wrapper g dir = function let xs = Array.to_list xs in xs @ lstatlist_wrapper g dir names -(* Same as above for guestfs_readlinklist. *) -and 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 +(* 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) + ) + +(* 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 (* Start up one slave thread. *) let slave_thread = Thread.create loop ()