vmm_stats: more debug, ignore vmmapi_open failure

vmm_stats_lwt: drop all pids on socket disconnect
vmmd: setup statistics slightly later (after the chmod on FreeBSD)

app/vmm_console.ml

@@ -146,7 +146,8 @@ let handle s addr () =
         Lwt.return_unit
   in
   loop () >>= fun () ->
-  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit)
+  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
+  Logs.warn (fun m -> m "disconnected")
 
 let jump _ file =
   Sys.(set_signal sigpipe Signal_ignore) ;

app/vmmd.ml

@@ -80,8 +80,15 @@ let handle ca state t =
               state := state' ;
               process state outs) ;
           process state outs >>= fun () ->
-          let _ = Vmm_commands.setup_freebsd_kludge vm.Vmm_core.pid in
+          begin
-          Lwt.return_unit
+            match Vmm_engine.setup_stats !state vm with
+            | Ok (state', outs) ->
+              state := state' ;
+              process state outs
+            | Error (`Msg e) ->
+              Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ;
+              Lwt.return_unit
+          end
         | Error (`Msg e) ->
           Logs.err (fun m -> m "error while cont %s" e) ;
           let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in

src/vmm_engine.ml

@@ -151,7 +151,6 @@ let handle_create t prefix chain cert force =
         Vmm_commands.exec t.dir vm_config tmpfile taps >>= fun vm ->
         Logs.debug (fun m -> m "exec()ed vm") ;
         Vmm_resources.insert t.resources full vm >>= fun resources ->
-        let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.pid vm.taps in
         let bridges =
           List.fold_left2 (fun b br ta ->
               let old = match String.Map.find br b with
@@ -161,10 +160,16 @@ let handle_create t prefix chain cert force =
               String.Map.add br (String.Set.add ta old) b)
             t.bridges vm_config.network taps
         in
-        let t = { t with resources ; stats_counter = succ t.stats_counter ; bridges } in
+        let t = { t with resources ; bridges } in
         let t, out = log t (Log.hdr prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in
         let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in
-        Ok (t, `Tls (s, tls_out) :: stat t stat_out @ out, vm))
+        Ok (t, `Tls (s, tls_out) :: out, vm))
+
+let setup_stats t vm =
+  Vmm_commands.setup_freebsd_kludge vm.Vmm_core.pid >>= fun () ->
+  let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.pid vm.taps in
+  let t = { t with stats_counter = succ t.stats_counter } in
+  Ok (t, stat t stat_out)
 
 let handle_shutdown t vm r =
   (match Vmm_commands.shutdown vm with

stats/vmm_stats.ml

@@ -1,6 +1,7 @@
 (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Astring
+open Rresult.R.Infix
 
 open Vmm_core
 
@@ -20,29 +21,37 @@ let my_version = `WV0
 let descr = ref []
 
 type t = {
-  pid_nic : (vmctx * (int * string) list) IM.t ;
+  pid_nic : (vmctx option * (int * string) list) IM.t ;
   pid_rusage : rusage IM.t ;
   pid_vmmapi : (string * int64) list IM.t ;
   nic_ifdata : ifdata String.Map.t ;
 }
 
+let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps
+
 let empty () =
   { pid_nic = IM.empty ; pid_rusage = IM.empty ; pid_vmmapi = IM.empty ; nic_ifdata = String.Map.empty }
 
 let rec wrap f arg =
   try Some (f arg) with
   | Unix.Unix_error (Unix.EINTR, _, _) -> wrap f arg
-  | _ -> None
+  | e ->
+    Logs.err (fun m -> m "exception %s" (Printexc.to_string e)) ;
+    None
 
 let gather pid vmctx nics =
   wrap sysctl_rusage pid,
-  wrap vmmapi_stats vmctx,
+  (match vmctx with
+   | None -> None
+   | Some vmctx -> wrap vmmapi_stats vmctx),
   List.fold_left (fun ifd (nic, nname) ->
       match wrap sysctl_ifdata nic with
       | None ->
         Logs.warn (fun m -> m "failed to get ifdata for %s" nname) ;
         ifd
-      | Some data -> String.Map.add data.name data ifd)
+      | Some data ->
+        Logs.debug (fun m -> m "adding ifdata for %s" nname) ;
+        String.Map.add data.name data ifd)
     String.Map.empty nics
 
 let tick t =
@@ -54,12 +63,16 @@ let tick t =
          | None ->
            Logs.warn (fun m -> m "failed to get rusage for %d" pid) ;
            rus
-         | Some ru -> IM.add pid ru rus),
+         | Some ru ->
+           Logs.debug (fun m -> m "adding resource usage for %d" pid) ;
+           IM.add pid ru rus),
         (match vmm with
          | None ->
            Logs.warn (fun m -> m "failed to get vmmapi_stats for %d" pid) ;
            vmms
-         | Some vmm -> IM.add pid (List.combine !descr vmm) vmms),
+         | Some vmm ->
+           Logs.debug (fun m -> m "adding vmmapi_stats for %d" pid) ;
+           IM.add pid (List.combine !descr vmm) vmms),
         String.Map.union (fun _k a _b -> Some a) ifd ifds)
       t.pid_nic (IM.empty, IM.empty, String.Map.empty)
   in
@@ -73,19 +86,18 @@ let fill_descr ctx =
         Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ;
         ()
       | Some d ->
-        Logs.info (fun m -> m "descr are %a" Fmt.(list ~sep:(unit ",@ ") string) d) ;
+        Logs.info (fun m -> m "descr are %a" pp_strings d) ;
         descr := d
     end
-  | ds ->
+  | ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds))
-    Logs.info (fun m -> m "descr are already %a" Fmt.(list ~sep:(unit ",@ ") string) ds)
 
 let add_pid t pid nics =
   let name = "ukvm" ^ string_of_int pid in
-  match wrap sysctl_ifcount (), wrap vmmapi_open name with
+  match wrap sysctl_ifcount () with
-  | None, _ -> Error (`Msg "sysctl ifcount failed")
+  | None ->
-  | _, None -> Error (`Msg "vmmapi_open failed")
+    Logs.err (fun m -> m "sysctl ifcount failed for %d %a" pid pp_strings nics) ;
-  | Some max_nic, Some vmctx ->
+    Error (`Msg "sysctl ifcount failed")
-    fill_descr vmctx ;
+  | Some max_nic ->
     let rec go cnt acc id =
       if id > 0 && cnt > 0 then
         match wrap sysctl_ifdata id with
@@ -95,11 +107,22 @@ let add_pid t pid nics =
       else
         List.rev acc
     in
-    let nic_ids = go (List.length nics) [] max_nic in
+    Ok (go (List.length nics) [] max_nic) >>= fun nic_ids ->
+    (match wrap vmmapi_open name with
+     | None ->
+       Logs.warn (fun m -> m "(ignored) vmmapi_open failed for %d" pid) ;
+       Ok None
+     | Some vmctx ->
+       fill_descr vmctx ;
+       Ok (Some vmctx)) >>= fun vmctx ->
+    Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics
+                  (match vmctx with None -> false | Some _ -> true)) ;
     let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic in
     Ok { t with pid_nic }
 
+
 let stats t pid =
+  Logs.debug (fun m -> m "querying statistics for %d" pid) ;
   try
     let _, nics = IM.find pid t.pid_nic
     and ru = IM.find pid t.pid_rusage
@@ -123,16 +146,17 @@ let stats t pid =
   | _ -> Error (`Msg "failed to find resource usage")
 
 let remove_pid t pid =
+  Logs.info (fun m -> m "removing pid %d" pid) ;
   (try
-     let vmctx, _ = IM.find pid t.pid_nic in
+     match IM.find pid t.pid_nic with
-     let _ = wrap vmmapi_close vmctx in
+     | Some vmctx, _ -> ignore (wrap vmmapi_close vmctx)
-     ()
+     | None, _ -> ()
    with
      _ -> ()) ;
   let pid_nic = IM.remove pid t.pid_nic in
   { t with pid_nic }
 
-open Rresult.R.Infix
+let remove_all t = IM.iter (fun pid _ -> ignore (remove_pid t pid)) t.pid_nic
 
 let handle t hdr buf =
   let open Vmm_wire in

stats/vmm_stats_lwt.ml

@@ -37,7 +37,10 @@ let handle s addr () =
       | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit
   in
   loop () >>= fun () ->
-  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit)
+  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
+  Logs.warn (fun m -> m "disconnect, dropping vmm_stats!") ;
+  Vmm_stats.remove_all !t ;
+  t := Vmm_stats.empty ()
 
 let rec timer () =
   t := Vmm_stats.tick !t ;

stats/vmm_stats_stubs.c

@@ -213,12 +213,12 @@ CAMLprim value vmmanage_sysctl_ifdata (value num) {
 
 CAMLprim value vmmanage_vmmapi_open (value name) {
   CAMLparam1(name);
-  CAMLreturn(Val_int(0));
+  uerror("vmmapi_open", Nothing);
 }
 
 CAMLprim value vmmanage_vmmapi_close (value name) {
   CAMLparam1(name);
-  CAMLreturn(Val_unit);
+  uerror("vmmapi_close", Nothing);
 }
 
 CAMLprim value vmmanage_vmmapi_stats (value name) {