CA-120525: Open VHD files RO where possible

Signed-off-by: Si Beaumont <simon.beaumont@citrix.com>

src/impl.ml

@@ -30,7 +30,7 @@ let get common filename key =
     let filename = require "filename" filename in
     let key = require "key" key in
     let t =
-      Vhd_IO.openfile ~path:common.path filename >>= fun t ->
+      Vhd_IO.openfile ~path:common.path filename false >>= fun t ->
       let result = Vhd.Field.get t key in
       Vhd_IO.close t >>= fun () ->
       return result in
@@ -49,7 +49,7 @@ let info common filename =
   try
     let filename = require "filename" filename in
     let t =
-      Vhd_IO.openfile ~path:common.path filename >>= fun t ->
+      Vhd_IO.openfile ~path:common.path filename false >>= fun t ->
       let all = List.map (fun f ->
         match Vhd.Field.get t f with
         | Some v -> [ f; v ]
@@ -75,7 +75,7 @@ let create common filename size parent =
       Lwt_main.run t
     | Some parent, None ->
       let t =
-        Vhd_IO.openfile ~path:common.path parent >>= fun parent ->
+        Vhd_IO.openfile ~path:common.path parent false >>= fun parent ->
         Vhd_IO.create_difference ~filename ~parent () >>= fun vhd ->
         Vhd_IO.close parent >>= fun () ->
         Vhd_IO.close vhd >>= fun () ->
@@ -92,7 +92,7 @@ let check common filename =
   try
     let filename = require "filename" filename in
     let t =
-      Vhd_IO.openfile ~path:common.path filename >>= fun vhd ->
+      Vhd_IO.openfile ~path:common.path filename false >>= fun vhd ->
       Vhd.check_overlapping_blocks vhd;
       return () in
     Lwt_main.run t;
@@ -279,26 +279,26 @@ let make_stream common source relative_to source_format destination_format =
     (* expect source to be block_device:vhd *)
     begin match Re_str.bounded_split colon source 2 with
     | [ raw; vhd ] ->
-      Vhd_IO.openfile ~path:common.path vhd >>= fun t ->
-      Vhd_lwt.Fd.openfile raw >>= fun raw ->
-      ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f >>= fun t -> return (Some t) ) >>= fun from ->
+      Vhd_IO.openfile ~path:common.path vhd false >>= fun t ->
+      Vhd_lwt.Fd.openfile raw false >>= fun raw ->
+      ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f false >>= fun t -> return (Some t) ) >>= fun from ->
       Vhd_input.hybrid ?from raw t
     | _ ->
       fail (Failure (Printf.sprintf "Failed to parse hybrid source: %s (expected raw_disk|vhd_disk)" source))
     end
   | "vhd", "vhd" ->
-    Vhd_IO.openfile ~path:common.path source >>= fun t ->
-    ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f >>= fun t -> return (Some t) ) >>= fun from ->
+    Vhd_IO.openfile ~path:common.path source false >>= fun t ->
+    ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f false >>= fun t -> return (Some t) ) >>= fun from ->
     Vhd_input.vhd ?from t
   | "vhd", "raw" ->
-    Vhd_IO.openfile ~path:common.path source >>= fun t ->
-    ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f >>= fun t -> return (Some t) ) >>= fun from ->
+    Vhd_IO.openfile ~path:common.path source false >>= fun t ->
+    ( match relative_to with None -> return None | Some f -> Vhd_IO.openfile ~path:common.path f false >>= fun t -> return (Some t) ) >>= fun from ->
     Vhd_input.raw ?from t
   | "raw", "vhd" ->
-    Raw_IO.openfile source >>= fun t ->
+    Raw_IO.openfile source false >>= fun t ->
     Raw_input.vhd t
   | "raw", "raw" ->
-    Raw_IO.openfile source >>= fun t ->
+    Raw_IO.openfile source false >>= fun t ->
     Raw_input.raw t
   | _, _ -> assert false
 
@@ -552,7 +552,7 @@ let serve common source source_fd source_protocol destination destination_format
         | File path ->
           let stats = Unix.LargeFile.stat path in
           let size = stats.Unix.LargeFile.st_size in
-          Fd.openfile path >>= fun fd ->
+          Fd.openfile path false >>= fun fd ->
           return (fd, size)
         | _ -> failwith (Printf.sprintf "Not implemented: writing to destination %s" destination) ) >>= fun (destination_fd, default_size) ->
       let fn = match source_protocol, size with