Libguestfs - Nov 2017 - [PATCH 2/2] common/mlstdutils: Add with_openfile function.

These safe wrappers around Pervasives.open_in and Pervasives.open_out
ensure that exceptions escaping cannot leave unclosed files.
---
 common/mlstdutils/std_utils.ml  | 39 ++++++++++++++++++++--------------
 common/mlstdutils/std_utils.mli | 12 +++++++++++
 common/mltools/tools_utils.ml   | 39 +++++++++++++++++-----------------
 dib/dib.ml                      |  9 ++++----
 generator/bindtests.ml          | 26 ++++++++++++-----------
 generator/utils.ml              | 14 ++++---------
 v2v/changeuid.ml                |  7 +------
 v2v/copy_to_local.ml            |  4 +---
 v2v/input_libvirt_vddk.ml       |  9 ++++----
 v2v/input_ova.ml                | 46 +++++++++++++++++++++--------------------
 v2v/output_local.ml             |  4 +---
 v2v/output_qemu.ml              | 29 +++++++++++++-------------
 v2v/output_vdsm.ml              |  8 ++-----
 13 files changed, 127 insertions(+), 119 deletions(-)

diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index ba23f39ed..ee6bea5af 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -654,20 +654,29 @@ let verbose = ref false
 let set_verbose () = verbose := true
 let verbose () = !verbose
 
+let with_open_in filename f +  let chan = open_in filename in
+  protect ~f:(fun () -> f chan) ~finally:(fun () -> close_in chan)
+
+let with_open_out filename f +  let chan = open_out filename in
+  protect ~f:(fun () -> f chan) ~finally:(fun () -> close_out chan)
+
 let read_whole_file path    let buf = Buffer.create 16384 in
-  let chan = open_in path in
-  let maxlen = 16384 in
-  let b = Bytes.create maxlen in
-  let rec loop () -    let r = input chan b 0 maxlen in
-    if r > 0 then (
-      Buffer.add_substring buf (Bytes.to_string b) 0 r;
+  with_open_in path (
+    fun chan ->
+      let maxlen = 16384 in
+      let b = Bytes.create maxlen in
+      let rec loop () +        let r = input chan b 0 maxlen in
+        if r > 0 then (
+          Buffer.add_substring buf (Bytes.to_string b) 0 r;
+          loop ()
+        )
+      in
       loop ()
-    )
-  in
-  loop ();
-  close_in chan;
+  );
   Buffer.contents buf
 
 (* Compare two version strings intelligently. *)
@@ -824,10 +833,10 @@ let last_part_of str sep    with Not_found -> None
 
 let read_first_line_from_file filename -  let chan = open_in filename in
-  let line = try input_line chan with End_of_file -> "" in
-  close_in chan;
-  line
+  with_open_in filename (
+    fun chan ->
+      try input_line chan with End_of_file -> ""
+  )
 
 let is_regular_file path = (* NB: follows symlinks. *)
   try (Unix.stat path).Unix.st_kind = Unix.S_REG
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index 96c55a511..7af6c2111 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -387,6 +387,18 @@ val verbose : unit -> bool
 (** Stores the colours ([--colours]), quiet ([--quiet]), trace ([-x])
     and verbose ([-v]) flags in global variables. *)
 
+val with_open_in : string -> (in_channel -> 'a) -> 'a
+(** [with_open_in filename f] calls function [f] with [filename]
+    open for input.  The file is always closed either on normal
+    return or if the function [f] throws an exception, so this is
+    both safer and more concise than the regular function. *)
+
+val with_open_out : string -> (out_channel -> 'a) -> 'a
+(** [with_open_out filename f] calls function [f] with [filename]
+    open for output.  The file is always closed either on normal
+    return or if the function [f] throws an exception, so this is
+    both safer and more concise than the regular function. *)
+
 val read_whole_file : string -> string
 (** Read in the whole file as a string. *)
 
diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
index 8140ba84d..95658a75f 100644
--- a/common/mltools/tools_utils.ml
+++ b/common/mltools/tools_utils.ml
@@ -478,26 +478,25 @@ let debug_augeas_errors g  
 (* Detect type of a file. *)
 let detect_file_type filename -  let chan = open_in filename in
-  let get start size -    try
-      seek_in chan start;
-      let b = Bytes.create size in
-      really_input chan b 0 size;
-      Some (Bytes.to_string b)
-    with End_of_file | Invalid_argument _ -> None
-  in
-  let ret -    if get 0 6 = Some "\2537zXZ\000" then `XZ
-    else if get 0 4 = Some "PK\003\004" then `Zip
-    else if get 0 4 = Some "PK\005\006" then `Zip
-    else if get 0 4 = Some "PK\007\008" then `Zip
-    else if get 257 6 = Some "ustar\000" then `Tar
-    else if get 257 8 = Some "ustar\x20\x20\000" then `Tar
-    else if get 0 2 = Some "\x1f\x8b" then `GZip
-    else `Unknown in
-  close_in chan;
-  ret
+  with_open_in filename (
+    fun chan ->
+      let get start size +        try
+          seek_in chan start;
+          let b = Bytes.create size in
+          really_input chan b 0 size;
+          Some (Bytes.to_string b)
+        with End_of_file | Invalid_argument _ -> None
+      in
+      if get 0 6 = Some "\2537zXZ\000" then `XZ
+      else if get 0 4 = Some "PK\003\004" then `Zip
+      else if get 0 4 = Some "PK\005\006" then `Zip
+      else if get 0 4 = Some "PK\007\008" then `Zip
+      else if get 257 6 = Some "ustar\000" then `Tar
+      else if get 257 8 = Some "ustar\x20\x20\000" then `Tar
+      else if get 0 2 = Some "\x1f\x8b" then `GZip
+      else `Unknown
+  )
 
 let is_partition dev    try
diff --git a/dib/dib.ml b/dib/dib.ml
index 9a8d86bd9..94ad3003a 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -60,10 +60,11 @@ let read_dib_envvars ()    String.concat "" vars
 
 let write_script fn text -  let oc = open_out fn in
-  output_string oc text;
-  flush oc;
-  close_out oc;
+  with_open_out fn (
+    fun oc ->
+      output_string oc text;
+      flush oc
+  );
   Unix.chmod fn 0o755
 
 let envvars_string l diff --git a/generator/bindtests.ml
b/generator/bindtests.ml
index 4bdff8092..79b020326 100644
--- a/generator/bindtests.ml
+++ b/generator/bindtests.ml
@@ -966,18 +966,20 @@ and generate_php_bindtests ()    pr
"--EXPECT--\n";
 
   let dump filename -    let chan = open_in filename in
-    let rec loop () -      let line = input_line chan in
-      (match String.nsplit ":" line with
-      |
("obool"|"oint"|"oint64"|"ostring"|"ostringlist")
as x :: _ ->
-        pr "%s: unset\n" x
-      | _ -> pr "%s\n" line
-      );
-      loop ()
-    in
-    (try loop () with End_of_file -> ());
-    close_in chan in
+    with_open_in filename (
+      fun chan ->
+        let rec loop () +          let line = input_line chan in
+          (match String.nsplit ":" line with
+           |
("obool"|"oint"|"oint64"|"ostring"|"ostringlist")
as x :: _ ->
+              pr "%s: unset\n" x
+           | _ -> pr "%s\n" line
+          );
+          loop ()
+        in
+        (try loop () with End_of_file -> ());
+    )
+  in
 
   dump "bindtests"
 
diff --git a/generator/utils.ml b/generator/utils.ml
index b818a0b3c..e91fed577 100644
--- a/generator/utils.ml
+++ b/generator/utils.ml
@@ -179,19 +179,13 @@ type memo_value = string list (* list of lines of POD file
*)
 
 let pod2text_memo_filename = "generator/.pod2text.data.version.2"
 let pod2text_memo : (memo_key, memo_value) Hashtbl.t -  try
-    let chan = open_in pod2text_memo_filename in
-    let v = input_value chan in
-    close_in chan;
-    v
-  with
-    _ -> Hashtbl.create 13
+  try with_open_in pod2text_memo_filename input_value
+  with  _ -> Hashtbl.create 13
 let pod2text_memo_unsaved_count = ref 0
 let pod2text_memo_atexit = ref false
 let pod2text_memo_save () -  let chan = open_out pod2text_memo_filename in
-  output_value chan pod2text_memo;
-  close_out chan
+  with_open_out pod2text_memo_filename
+                (fun chan -> output_value chan pod2text_memo)
 let pod2text_memo_updated ()    if not (!pod2text_memo_atexit) then (
     at_exit pod2text_memo_save;
diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index 49290c298..f4c5c90d1 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -66,12 +66,7 @@ let rmdir t path    with_fork t (sprintf "rmdir:
%s" path) (fun () -> rmdir path)
 
 let output t path f -  with_fork t path (
-    fun () ->
-      let chan = open_out path in
-      f chan;
-      close_out chan
-  )
+  with_fork t path (fun () -> with_open_out path f)
 
 let make_file t path content    output t path (fun chan -> output_string
chan content)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index f1a67fc14..3e41016c5 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -226,9 +226,7 @@ read the man page virt-v2v-copy-to-local(1).
 
   let guest_xml = guest_name ^ ".xml" in
   message (f_"Writing libvirt XML metadata to %s ...") guest_xml;
-  let chan = open_out guest_xml in
-  output_string chan xml;
-  close_out chan;
+  with_open_out guest_xml (fun chan -> output_string chan xml);
 
   (* Finished, so don't delete the disks on exit. *)
   message (f_"Finishing off");
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index 63e76a5aa..e29fbc2b7 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -240,10 +240,11 @@ object
            "password=-"
         | Some password ->
            let password_file = tmpdir // "password" in
-           let chan = open_out password_file in
-           chmod password_file 0o600;
-           output_string chan password;
-           close_out chan;
+           with_open_out password_file (
+             fun chan ->
+               chmod password_file 0o600;
+               output_string chan password
+           );
            (* nbdkit reads the password from the file *)
            "password=+" ^ password_file in
       add_arg (sprintf "server=%s" server);
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index abb0654a5..ff00118b3 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -215,29 +215,31 @@ object
         debug "processing manifest %s" mf;
         let mf_folder = Filename.dirname mf in
         let mf_subfolder = subdirectory exploded mf_folder in
-        let chan = open_in mf in
-        let rec loop () -          let line = input_line chan in
-          if PCRE.matches rex line then (
-            let mode = PCRE.sub 1
-            and disk = PCRE.sub 2
-            and expected = PCRE.sub 3 in
-            let csum = Checksums.of_string mode expected in
-            try
-              if partial then
-                Checksums.verify_checksum csum ~tar:ova (mf_subfolder // disk)
+        with_open_in mf (
+          fun chan ->
+            let rec loop () +              let line = input_line chan in
+              if PCRE.matches rex line then (
+                let mode = PCRE.sub 1
+                and disk = PCRE.sub 2
+                and expected = PCRE.sub 3 in
+                let csum = Checksums.of_string mode expected in
+                try
+                  if partial then
+                    Checksums.verify_checksum csum
+                                              ~tar:ova (mf_subfolder // disk)
+                  else
+                    Checksums.verify_checksum csum (mf_folder // disk)
+                with Checksums.Mismatched_checksum (_, actual) ->
+                  error (f_"checksum of disk %s does not match manifest %s
(actual %s(%s) = %s, expected %s(%s) = %s)")
+                        disk mf mode disk actual mode disk expected;
+              )
               else
-                Checksums.verify_checksum csum (mf_folder // disk)
-            with Checksums.Mismatched_checksum (_, actual) ->
-              error (f_"checksum of disk %s does not match manifest %s
(actual %s(%s) = %s, expected %s(%s) = %s)")
-                disk mf mode disk actual mode disk expected;
-          )
-          else
-            warning (f_"unable to parse line from manifest file: %S")
line;
-          loop ()
-        in
-        (try loop () with End_of_file -> ());
-        close_in chan
+                warning (f_"unable to parse line from manifest file:
%S") line;
+              loop ()
+            in
+            (try loop () with End_of_file -> ())
+        )
     ) mf;
 
     let ovf_folder = Filename.dirname ovf in
diff --git a/v2v/output_local.ml b/v2v/output_local.ml
index 93d643f03..97ad8dddd 100644
--- a/v2v/output_local.ml
+++ b/v2v/output_local.ml
@@ -67,9 +67,7 @@ class output_local dir = object
     let name = source.s_name in
     let file = dir // name ^ ".xml" in
 
-    let chan = open_out file in
-    DOM.doc_to_chan chan doc;
-    close_out chan
+    with_open_out file (fun chan -> DOM.doc_to_chan chan doc)
 end
 
 let output_local = new output_local
diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml
index 5304329ae..f61d698d6 100644
--- a/v2v/output_qemu.ml
+++ b/v2v/output_qemu.ml
@@ -229,23 +229,24 @@ object
       arg "-serial" "stdio";
 
     (* Write the output file. *)
-    let chan = open_out file in
-    let fpf fs = fprintf chan fs in
-    fpf "#!/bin/sh -\n";
-    fpf "\n";
+    with_open_out file (
+      fun chan ->
+        let fpf fs = fprintf chan fs in
+        fpf "#!/bin/sh -\n";
+        fpf "\n";
 
-    (match uefi_firmware with
-     | None -> ()
-     | Some { Uefi.vars = vars_template } ->
-        fpf "# Make a copy of the UEFI variables template\n";
-        fpf "uefi_vars=\"$(mktemp)\"\n";
-        fpf "cp %s \"$uefi_vars\"\n" (quote vars_template);
-        fpf "\n"
+        (match uefi_firmware with
+         | None -> ()
+         | Some { Uefi.vars = vars_template } ->
+            fpf "# Make a copy of the UEFI variables template\n";
+            fpf "uefi_vars=\"$(mktemp)\"\n";
+            fpf "cp %s \"$uefi_vars\"\n" (quote
vars_template);
+            fpf "\n"
+        );
+
+        Qemuopts.to_chan cmd chan
     );
 
-    Qemuopts.to_chan cmd chan;
-    close_out chan;
-
     Unix.chmod file 0o755;
 
     (* If --qemu-boot option was specified then we should boot the guest. *)
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 0aeee289d..d5911e80e 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -144,9 +144,7 @@ object
     List.iter (
       fun ({ target_file }, meta) ->
         let meta_filename = target_file ^ ".meta" in
-        let chan = open_out meta_filename in
-        output_string chan meta;
-        close_out chan
+        with_open_out meta_filename (fun chan -> output_string chan meta)
     ) (List.combine targets metas);
 
     (* Return the list of targets. *)
@@ -177,9 +175,7 @@ object
 
     (* Write it to the metadata file. *)
     let file = vdsm_params.ovf_output // vdsm_params.vm_uuid ^ ".ovf"
in
-    let chan = open_out file in
-    DOM.doc_to_chan chan ovf;
-    close_out chan
+    with_open_out file (fun chan -> DOM.doc_to_chan chan ovf)
 end
 
 let output_vdsm = new output_vdsm
-- 
2.13.2

This safe wrapper around Unix.openfile ensures that exceptions
escaping cannot leave unclosed files.

There are only a few places in the code where this wrapper can be used
currently.  There are other occurences of Unix.openfile but they are
not suitable for replacement.
---
 common/mlstdutils/std_utils.ml  |  4 ++++
 common/mlstdutils/std_utils.mli |  6 ++++++
 daemon/devsparts.ml             |  5 ++---
 daemon/inspect_fs_windows.ml    | 18 ++++++++----------
 4 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index ee6bea5af..32944ed27 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -662,6 +662,10 @@ let with_open_out filename f    let chan = open_out
filename in
   protect ~f:(fun () -> f chan) ~finally:(fun () -> close_out chan)
 
+let with_openfile filename flags perms +  let fd = Unix.openfile filename flags
perms in
+  protect ~f:(fun () -> f fd) ~finally:(fun () -> close fd)
+
 let read_whole_file path    let buf = Buffer.create 16384 in
   with_open_in path (
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index 7af6c2111..178762819 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -399,6 +399,12 @@ val with_open_out : string -> (out_channel -> 'a)
-> 'a
     return or if the function [f] throws an exception, so this is
     both safer and more concise than the regular function. *)
 
+val with_openfile : string -> Unix.open_flag list -> Unix.file_perm ->
(Unix.file_desc -> 'a) -> 'a
+(** [with_openfile] calls function [f] with [filename] opened by the
+    {!Unix.openfile} function.  The file is always closed either on
+    normal return or if the function [f] throws an exception, so this
+    is both safer and more concise than the regular function. *)
+
 val read_whole_file : string -> string
 (** Read in the whole file as a string. *)
 
diff --git a/daemon/devsparts.ml b/daemon/devsparts.ml
index 7395de923..0eb7c1282 100644
--- a/daemon/devsparts.ml
+++ b/daemon/devsparts.ml
@@ -49,9 +49,8 @@ let map_block_devices ~return_md f      List.filter (
       fun dev ->
         try
-          let fd = openfile ("/dev/" ^ dev) [O_RDONLY; O_CLOEXEC] 0
in
-          close fd;
-          true
+          with_openfile ("/dev/" ^ dev) [O_RDONLY; O_CLOEXEC] 0
+                        (fun _ -> true)
         with _ -> false
     ) devs in
 
diff --git a/daemon/inspect_fs_windows.ml b/daemon/inspect_fs_windows.ml
index 7c42fc5d7..112cc2f92 100644
--- a/daemon/inspect_fs_windows.ml
+++ b/daemon/inspect_fs_windows.ml
@@ -429,16 +429,14 @@ and extract_guid_from_registry_blob blob            (data4
&^ 0xffffffffffff_L)
 
 and pread device size offset -  let fd = Unix.openfile device [Unix.O_RDONLY;
Unix.O_CLOEXEC] 0 in
-  let ret -    protect ~f:(
-      fun () ->
-        ignore (Unix.lseek fd offset Unix.SEEK_SET);
-        let ret = Bytes.create size in
-        if Unix.read fd ret 0 size < size then
-          failwithf "pread: %s: short read" device;
-        ret
-    ) ~finally:(fun () -> Unix.close fd) in
+  with_openfile device [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 (
+    fun fd ->
+      ignore (Unix.lseek fd offset Unix.SEEK_SET);
+      let ret = Bytes.create size in
+      if Unix.read fd ret 0 size < size then
+        failwithf "pread: %s: short read" device;
+      ret
+  );
   Bytes.to_string ret
 
 (* Get the hostname. *)
-- 
2.13.2

On Sunday, 5 November 2017 20:42:40 CET Richard W.M. Jones
wrote:
> These safe wrappers around Pervasives.open_in and Pervasives.open_out
> ensure that exceptions escaping cannot leave unclosed files.
> ---
Mostly LGTM, just one note/improvement.
> diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
> index 63e76a5aa..e29fbc2b7 100644
> --- a/v2v/input_libvirt_vddk.ml
> +++ b/v2v/input_libvirt_vddk.ml
> @@ -240,10 +240,11 @@ object
>             "password=-"
>          | Some password ->
>             let password_file = tmpdir // "password" in
> -           let chan = open_out password_file in
> -           chmod password_file 0o600;
> -           output_string chan password;
> -           close_out chan;
> +           with_open_out password_file (
> +             fun chan ->
> +               chmod password_file 0o600;
> +               output_string chan password
> +           );
Now that I see this, the chmod could be directly on the fd of the open
channel, to be sure to perform it on the actual file:

  fchmod (descr_of_out_channel chan) 0o600;

Thanks,
-- 
Pino Toscano

On Sunday, 5 November 2017 20:42:41 CET Richard W.M. Jones
wrote:
> This safe wrapper around Unix.openfile ensures that exceptions
> escaping cannot leave unclosed files.
> 
> There are only a few places in the code where this wrapper can be used
> currently.  There are other occurences of Unix.openfile but they are
> not suitable for replacement.
> ---
LGTM.

Thanks,
-- 
Pino Toscano