Silence stderr for zfs

lib/os.ml

@@ -43,14 +43,17 @@ let close_redirection (x : [`FD_move_safely of unix_fd | `Dev_null]) =
   | `FD_move_safely x -> ensure_closed_unix x
   | `Dev_null -> ()
 
+let log_std v =
+  Logs.info (fun f -> f "Stderr %s" (match v with Some `Dev_null -> "DEVNULL" | Some `FD_move_safely _ -> "FD" | None -> "none"))
+
 (* stdin, stdout and stderr are copied to the child and then closed on the host.
    They are closed at most once, so duplicates are OK. *)
 let default_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp argv =
   let proc =
     let stdin  = Option.map redirection stdin in
     let stdout = Option.map redirection stdout in
     let stderr = Option.map redirection stderr in
-    try Lwt_result.ok (Lwt_process.exec ?timeout ?cwd ?stdin ?stdout ?stderr argv)
+    try Lwt_result.ok (Lwt_process.exec ?timeout ?cwd ?stdin ?stdout ~stderr:`Close argv)
     with e -> Lwt_result.fail e
   in
   Option.iter close_redirection stdin;
@@ -102,6 +105,7 @@ let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="")
 
 let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv =
   Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
+  log_std stderr;
   let pp f = pp_cmd f (cmd, argv) in
   !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
   | Ok n when is_success n -> Lwt.return_unit
@@ -110,13 +114,13 @@ let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") ar
 
 let running_as_root = not (Sys.unix) || Unix.getuid () = 0
 
-let sudo ?stdin args =
+let sudo ?(stdout=`Dev_null) ?stdin args =
   let args = if running_as_root then args else "sudo" :: "--" :: args in
-  exec ?stdin args
+  exec ?stdin ~stdout ~stderr:`Dev_null args
 
 let sudo_result ?cwd ?stdin ?stdout ?stderr ?is_success ~pp args =
   let args = if running_as_root then args else "sudo" :: "--" :: args in
-  exec_result ?cwd ?stdin ?stdout ?stderr ?is_success ~pp args
+  exec_result ?cwd ?stdin ?stdout ~stderr:`Dev_null ?is_success ~pp args
 
 let rec write_all fd buf ofs len =
   assert (len >= 0);

lib/zfs_store.ml

@@ -104,7 +104,7 @@ end = struct
         else strf "%s%s/.zfs/snapshot/%s" t.prefix (dataset_no_pool t.subdir ds) snapshot
 
   let exists_raw raw =
-    Lwt_process.pread ("", [| "zfs"; "list"; "-p"; "-H"; raw |]) >>= function
+    Lwt_process.pread ~stderr:`Dev_null ("", [| "zfs"; "list"; "-p"; "-H"; raw |]) >>= function
     | "" -> Lwt.return false
     | _ -> Lwt.return true
 
@@ -173,7 +173,7 @@ module Zfs = struct
     Os.sudo ["zfs"; "clone"; "--"; Dataset.full_name t src ~snapshot; Dataset.full_name t dst]
 
   let mounted ?snapshot t ~ds =
-    Lwt_process.pread ("", [| "zfs"; "get"; "-pH"; "mounted"; Dataset.full_name t ds ?snapshot |]) >>= fun s ->
+    Lwt_process.pread ~stderr:`Dev_null ("", [| "zfs"; "get"; "-pH"; "mounted"; Dataset.full_name t ds ?snapshot |]) >>= fun s ->
     match ( Scanf.sscanf s "%s %s %s %s" (fun _ _ yesno _ -> yesno = "yes") ) with
     | state -> Lwt.return state
     | exception Scanf.Scan_failure _ -> Lwt.return false
@@ -182,7 +182,7 @@ module Zfs = struct
     mounted t ~ds ?snapshot >>= fun m ->
     if not m then
       let pp _ ppf = Fmt.pf ppf "zfs mount" in
-      let* t = Os.sudo_result ~pp:(pp "zfs mount") ~is_success:(fun n -> n = 0 || n = 16) ["zfs"; "mount"; "--"; Dataset.full_name t ds ?snapshot] in
+      let* t = Os.sudo_result ~stdout:`Dev_null ~stderr:`Dev_null ~pp:(pp "zfs mount") ~is_success:(fun n -> n = 0 || n = 16) ["zfs"; "mount"; "--"; Dataset.full_name t ds ?snapshot] in
         match t with
         | Ok () -> Lwt.return ()
         | Error (`Msg m) ->
@@ -195,7 +195,7 @@ module Zfs = struct
     Os.sudo ["zfs"; "mount"; Dataset.full_name t dst] >>= fun () ->
     let vol = Dataset.full_name t src in
     let len = String.length vol in
-    Lwt_process.pread ("", [| "zfs"; "list"; "-H"; "-r"; "-o"; "name"; vol |]) >>= fun output ->
+    Lwt_process.pread ~stderr:`Dev_null ("", [| "zfs"; "list"; "-H"; "-r"; "-o"; "name"; vol |]) >>= fun output ->
     String.split_on_char '\n' output |> List.map (fun s -> (s, String.length s)) |>
       List.filter (fun (_, l) -> l > len) |> List.map (fun (s, l) -> String.sub s (len + 1) (l - len - 1)) |>
       Lwt_list.iter_s (fun subvolume -> Os.sudo ["zfs"; "clone"; "-o"; "mountpoint=none"; "--";
@@ -226,7 +226,7 @@ let state_dir t = Dataset.path t Dataset.state
 let root t = t.pool
 
 let df t =
-  Lwt_process.pread ("", [| "zpool"; "list"; "-Hp"; "-o"; "capacity"; t.pool |]) >>= fun s ->
+  Lwt_process.pread ~stderr:`Dev_null ("", [| "zpool"; "list"; "-Hp"; "-o"; "capacity"; t.pool |]) >>= fun s ->
   match (String.trim s) with
   | "" -> Lwt.return 0.
   | s -> Lwt.return (100. -. float_of_string s)