From bea873ce68b3e788c2926735fe3d513cbea24f06 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 13 Dec 2010 22:14:26 +0000 Subject: [PATCH] Daily checkin of rewritten code. --- filetree.ml | 67 ++++++++++++++++++++++++++++++++++++++++++++----------------- slave.ml | 54 ++++++++++++++++++++++++++++++++++++++----------- slave.mli | 7 ++++--- window.ml | 8 +++----- 4 files changed, 98 insertions(+), 38 deletions(-) diff --git a/filetree.ml b/filetree.ml index 0737820..0368d53 100644 --- a/filetree.ml +++ b/filetree.ml @@ -48,11 +48,11 @@ and state_t = | NodeNotStarted (* user has not tried to open this *) | NodeLoading (* user tried to open it, still loading *) | IsNode (* we've loaded the children of this directory *) - | Loading (* special row contains the "Loading ..." message *) (* The actual content of a row. *) and content_t = - | NoContent + | Loading (* special "loading ..." node *) + | ErrorMessage of string (* error message node *) | Top of Slave.source (* top level OS or volume node *) | Directory of Slave.direntry (* a directory *) | File of Slave.direntry (* a file inc. special files *) @@ -95,7 +95,7 @@ let create ~packing () = let renderer = GTree.cell_renderer_text [], ["markup", name_col] in let name_view = GTree.view_column ~title:"Filename" ~renderer () in - name_view#set_max_width 400 (*pixels?!?*); + name_view#set_max_width 300 (*pixels?!?*); ignore (view#append_column name_view); let renderer = GTree.cell_renderer_text [], ["text", size_col] in @@ -219,13 +219,19 @@ let rec add ({ model = model; hash = hash } as t) name data = List.iter (add_top_level_os t name) data.Slave.insp_oses; (* Add top level left-over filesystems. *) - DeviceSet.iter (add_top_level_vol t name) other_filesystems + DeviceSet.iter (add_top_level_vol t name) other_filesystems; + + (* Expand the first top level node. *) + match model#get_iter_first with + | None -> () + | Some row -> + t.view#expand_row (model#get_path row) and add_top_level_os ({ model = model; hash = hash } as t) name os = let markup = - sprintf "%s: %s (%s)" - (markup_of_name name) (markup_of_name os.Slave.insp_hostname) - (markup_of_name os.Slave.insp_product_name) in + sprintf "%s\n%s\n%s" + (markup_escape name) (markup_escape os.Slave.insp_hostname) + (markup_escape os.Slave.insp_product_name) in let row = model#append () in make_node t row (Top (Slave.OS os)); @@ -233,7 +239,7 @@ and add_top_level_os ({ model = model; hash = hash } as t) name os = and add_top_level_vol ({ model = model; hash = hash } as t) name dev = let markup = - sprintf "%s: %s" (markup_of_name name) (markup_of_name dev) in + sprintf "%s: %s" (markup_escape name) (markup_escape dev) in let row = model#append () in make_node t row (Top (Slave.Volume dev)); @@ -248,7 +254,7 @@ and make_node ({ model = model; hash = hash } as t) row content = * the user has something to expand. *) let placeholder = model#append ~parent:row () in - let hdata = Loading, NoContent in + let hdata = IsLeaf, Loading in store_hdata t placeholder hdata; model#set ~row:placeholder ~column:t.name_col loading_msg; ignore (t.view#connect#row_expanded ~callback:(expand_row t)) @@ -270,7 +276,8 @@ and expand_row ({ model = model; hash = hash } as t) row _ = (* Get a stable path for this row. *) let path = model#get_path row in - Slave.read_directory src "/" (when_read_directory t path) + Slave.read_directory ~fail:(when_read_directory_fail t path) + src "/" (when_read_directory t path) | NodeNotStarted, Directory direntry -> (* User has opened a filesystem directory not previously opened. *) @@ -284,15 +291,16 @@ and expand_row ({ model = model; hash = hash } as t) row _ = let src, pathname = get_pathname t row in - Slave.read_directory src pathname (when_read_directory t path) + Slave.read_directory ~fail:(when_read_directory_fail t path) + src pathname (when_read_directory t path) | NodeLoading, _ | IsNode, _ -> () (* These are not nodes so it should never be possible to open them. *) - | _, File _ | IsLeaf, _ | Loading, _ -> assert false + | _, File _ | IsLeaf, _ -> assert false - (* Should not exist in the tree. *) - | NodeNotStarted, NoContent -> assert false + (* Node should not exist in the tree. *) + | NodeNotStarted, (Loading | ErrorMessage _) -> assert false (* Search up to the top of the tree so we know if this directory * comes from an OS or a volume, and the full path to here. @@ -308,9 +316,9 @@ and get_pathname ({ model = model } as t) row = let parent = model#iter_parent row in match hdata, parent with - | (Loading, NoContent), Some parent -> + | (IsLeaf, Loading), Some parent -> get_pathname t parent - | (Loading, NoContent), None -> + | (IsLeaf, Loading), None -> assert false | (_, Directory { Slave.dent_name = name }), Some parent | (_, File { Slave.dent_name = name }), Some parent -> @@ -320,8 +328,10 @@ and get_pathname ({ model = model } as t) row = else parent_name ^ "/" ^ name in src, path | (_, Top src), _ -> src, "/" - | (_, Directory _), None | (_, File _), None -> assert false - | (_, NoContent), _ -> assert false + | (_, Directory _), None -> assert false + | (_, File _), None -> assert false + | (_, Loading), _ -> assert false + | (_, ErrorMessage _), _ -> assert false (* This is the callback when the slave has read the directory for us. *) and when_read_directory ({ model = model } as t) path entries = @@ -361,3 +371,24 @@ and when_read_directory ({ model = model } as t) path entries = let state, content = get_hdata t row in let hdata = IsNode, content in store_hdata t row hdata + +(* This is called instead of when_read_directory when the read directory + * (or mount etc) failed. Convert the "Loading" entry into the + * error message. + *) +and when_read_directory_fail ({ model = model } as t) path exn = + debug "when_read_directory_fail: %s" (Printexc.to_string exn); + + match exn with + | G.Error msg -> + let row = model#get_iter path in + let row = model#iter_children ~nth:0 (Some row) in + + let hdata = IsLeaf, ErrorMessage msg in + store_hdata t row hdata; + + model#set ~row ~column:t.name_col (markup_escape msg) + + | exn -> + (* unexpected exception: re-raise it *) + raise exn diff --git a/slave.ml b/slave.ml index 74ce217..a43cd69 100644 --- a/slave.ml +++ b/slave.ml @@ -33,7 +33,7 @@ type command = | Exit_thread | Connect of string option * domain list 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 = { @@ -77,12 +77,20 @@ let rec string_of_command = function | Connect (None, _) -> "Connect NULL" | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> - sprintf "Open_images [%s]" (String.concat "; " images) + sprintf "Open_images %s" (string_of_images 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 +and string_of_images images = + "[" ^ + String.concat "; " + (List.map (function + | fn, None -> fn + | fn, Some format -> sprintf "%s (%s)" fn format) + images) ^ "]" + let no_callback _ = () let failure_hook = ref (fun _ -> ()) @@ -307,18 +315,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,7 +351,7 @@ 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 @@ -342,7 +366,13 @@ and open_disk_images images cb = *) (* g#set_verbose (verbose ());*) - List.iter g#add_drive_ro images; + 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 (); diff --git a/slave.mli b/slave.mli index 0df8466..d6f9cf7 100644 --- a/slave.mli +++ b/slave.mli @@ -122,9 +122,10 @@ val open_domain : ?fail:exn callback -> string -> inspection_data callback -> un If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) -val open_images : ?fail:exn callback -> string list -> inspection_data callback -> unit - (** [open_images images cb] is like {!open_domain} except - that it opens local disk image(s) directly. +val open_images : ?fail:exn callback -> (string * string option) list -> inspection_data callback -> unit + (** [open_images images cb] is like {!open_domain} except that it + opens local disk image(s) directly. [images] is a list of + [(filename, format)] pairs. If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) diff --git a/window.ml b/window.ml index 323e847..b15c690 100644 --- a/window.ml +++ b/window.ml @@ -88,8 +88,7 @@ and open_disk_images ws images = match images with | [] -> () | images -> - set_statusbar ws (sprintf "Opening disk image %s ..." - (String.concat " " images)); + set_statusbar ws "Opening disks ..."; clear_view ws; Slave.discard_command_queue (); Slave.open_images images (when_opened_disk_images ws images) @@ -98,10 +97,9 @@ and open_disk_images ws images = and when_opened_disk_images ws images data = match images with | [] -> () - | image :: _ as images -> + | (image, _) :: _ -> debug "when_opened_disk_images callback"; - set_statusbar ws (sprintf "Opened disk image %s" - (String.concat " " images)); + set_statusbar ws "Opened disk"; when_opened_common ws image data (* Common code for when_opened_domain/when_opened_disk_images. *) -- 1.8.3.1