unify log output in vmmc_local/remote/bistro

app/vmm_cli.ml

@@ -3,6 +3,17 @@
 open Astring
 open Vmm_core
 
+open Lwt.Infix
+
+let print_result version (header, reply) =
+  if not (Vmm_commands.version_eq header.Vmm_commands.version version) then
+    Logs.err (fun m -> m "version not equal")
+  else match reply with
+    | `Success s -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
+    | `Data d -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
+    | `Failure d -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire (header, reply))
+    | `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire (header, reply))
+
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
   Logs.set_level level;

app/vmmc_bistro.ml

@@ -4,24 +4,14 @@ open Lwt.Infix
 
 let version = `AV2
 
-let process fd =
-  Vmm_tls_lwt.read_tls fd >|= function
-  | Error _ -> Error (`Msg "read or parse error")
-  | Ok (header, reply) ->
-    if Vmm_commands.version_eq header.Vmm_commands.version version then begin
-      Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
-      Ok ()
-    end else begin
-      Logs.err (fun m -> m "version not equal") ;
-      Error (`Msg "version not equal")
-    end
-
 let read fd =
   (* now we busy read and process output *)
   let rec loop () =
-    process fd >>= function
+    Vmm_tls_lwt.read_tls fd >>= function
-    | Error e -> Lwt.return (Error e)
+    | Error _ -> Lwt.return ()
-    | Ok () -> loop ()
+    | Ok wire ->
+      Vmm_cli.print_result version wire ;
+      loop ()
   in
   loop ()
 
@@ -71,11 +61,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
   read t
 
 let jump endp cert key ca name cmd =
-  match
+  `Ok (Lwt_main.run (handle endp cert key ca name cmd))
-    Lwt_main.run (handle endp cert key ca name cmd)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
 
 let info_ _ endp cert key ca name =
   jump endp cert key ca name (`Vm_cmd `Vm_info)

app/vmmc_local.ml

@@ -4,19 +4,6 @@ open Lwt.Infix
 
 let version = `AV2
 
-let process fd =
-  Vmm_lwt.read_wire fd >|= function
-  | Error _ ->
-    Error (`Msg "read or parse error")
-  | Ok (header, reply) ->
-    if Vmm_commands.version_eq header.Vmm_commands.version version then begin
-      Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
-      Ok ()
-    end else begin
-      Logs.err (fun m -> m "version not equal") ;
-      Error (`Msg "version not equal")
-    end
-
 let socket t = function
   | Some x -> x
   | None -> Vmm_core.socket_path t
@@ -27,11 +14,16 @@ let connect socket_path =
   Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
   c
 
+let process fd =
+  Vmm_lwt.read_wire fd >|= function
+  | Error _ -> Error ()
+  | Ok wire -> Ok (Vmm_cli.print_result version wire)
+
 let read fd =
   (* now we busy read and process output *)
   let rec loop () =
     process fd >>= function
-    | Error e -> Lwt.return (Error e)
+    | Error _ -> Lwt.return ()
     | Ok () -> loop ()
   in
   loop ()
@@ -41,20 +33,15 @@ let handle opt_socket id (cmd : Vmm_commands.t) =
   connect (socket sock opt_socket) >>= fun fd ->
   let header = Vmm_commands.{ version ; sequence = 0L ; id } in
   Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
-  | Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
+  | Error `Exception -> Lwt.return ()
   | Ok () ->
     (match next with
      | `Read -> read fd
-     | `End -> process fd) >>= fun res ->
+     | `End -> process fd >|= ignore) >>= fun () ->
-    Vmm_lwt.safe_close fd >|= fun () ->
+    Vmm_lwt.safe_close fd
-    res
 
 let jump opt_socket name cmd =
-  match
+  `Ok (Lwt_main.run (handle opt_socket name cmd))
-    Lwt_main.run (handle opt_socket name cmd)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
 
 let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info)
 

app/vmmc_remote.ml

@@ -2,11 +2,13 @@
 
 open Lwt.Infix
 
+let version = `AV2
+
 let rec read_tls_write_cons t =
   Vmm_tls_lwt.read_tls t >>= function
-  | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
+  | Error _ -> Lwt.return_unit
   | Ok wire ->
-    Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ;
+    Vmm_cli.print_result version wire ;
     read_tls_write_cons t
 
 let client cas host port cert priv_key =