Daily checkin of rewritten code.

diff --git a/filetree.ml b/filetree.ml
index 0737820..0368d53 100644 (file)
--- 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 "<b>%s</b>: %s (%s)"
-      (markup_of_name name) (markup_of_name os.Slave.insp_hostname)
-      (markup_of_name os.Slave.insp_product_name) in
+    sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
+      (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 "<b>%s</b>: %s" (markup_of_name name) (markup_of_name dev) in
+    sprintf "<b>%s: %s</b>" (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 (file)
--- 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 <driver type=attr_val/> 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 <disk> 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 (file)
--- 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 (file)
--- 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. *)