stats: transmit vmid in add/remove/stats, pid only in add

don't use /tmp anymore, but /var/run/albatross for fifos + sockets + vm images,
  and /var/db/albatross for ukvm-bin and crls, and /var/log/albatross for logging

vmm_console/vmm_log/vmm_stats_lwt: delete socket on startup if it exists

vmm_influxdb_stats: connects to vmm_stats socket and pushes every interval in
 influxdb line format via tcp to specified host and port

README.md

@@ -71,15 +71,15 @@ DEV> mirage configure -t ukvm
 DEV> mirage build
 DEV> mv ukvm-bin /tmp/ukvm-bin.net
 DEV> cd ../../..
-DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:
+DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:/var/db/albatross
-DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:
+DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:/opt/bin/
 ```
 
 ```
-SRV> vmm_console -vv cons.sock &
+SRV> vmm_console -vv &
-SRV> vmm_log -vv log.out log.sock &
+SRV> vmm_log -vv &
-SRV> vmm_stats_lwt -vv stat.sock & #optional
+SRV> vmm_stats_lwt -vv & #optional
-SRV# vmmd -vv . cacert.pem server.pem server.key
+SRV# vmmd -vv cacert.pem server.pem server.key
 ```
 
 Some setup for network interfaces is needed, depending on your operating system.

app/vmm_console.ml

@@ -56,7 +56,7 @@ let read_console s name ring channel () =
        Lwt_io.close channel)
 
 let open_fifo name =
-  let fifo = Fpath.(v (Filename.get_temp_dir_name ()) / name + "fifo") in
+  let fifo = Fpath.(Vmm_core.tmpdir / name + "fifo") in
   Lwt.catch (fun () ->
       Logs.debug (fun m -> m "opening %a for reading" Fpath.pp fifo) ;
       Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string fifo) >>= fun channel ->
@@ -152,7 +152,10 @@ let handle s addr () =
 let jump _ file =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Lwt_main.run
-    (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+    ((Lwt_unix.file_exists file >>= function
+       | true -> Lwt_unix.unlink file
+       | false -> Lwt.return_unit) >>= fun () ->
+     let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
      Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () ->
      Lwt_unix.listen s 1 ;
      let rec loop () =
@@ -175,8 +178,9 @@ let setup_log =
         $ Logs_cli.level ())
 
 let socket =
-  let doc = "Socket to listen onto" in
+  let doc = "Socket to listen on" in
-  Arg.(required & pos 0 (some string) None & info [] ~doc)
+  let sock = Fpath.(to_string (Vmm_core.tmpdir / "cons" + "sock")) in
+  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
 
 let cmd =
   Term.(ret (const jump $ setup_log $ socket)),

app/vmm_influxdb_stats.ml

@@ -0,0 +1,285 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+open Astring
+
+open Vmm_core
+
+
+(*
+line protocol:
+```
+  <measurement>[,<tag_key>=<tag_value>[,<tag_key>=<tag_value>]] \
+  <field_key>=<field_value>[,<field_key>=<field_value>] [<timestamp>]
+```
+
+(measurement, tag_key, tag_value, field_key are all strings, index over tags)
+
+* Quoting
+
+Element 	Double quotes 	Single quotes
+---------------------------------------------
+Timestamp 	Never 	Never
+Measurements, tag keys, tag values, field keys 	Never* 	Never*
+Field values 	Double quote string field values. Do not double quote floats,
+                                            integers, or Booleans. 	Never
+
+*=Line Protocol allows users to double and single quote measurement names, tag
+  keys, tag values, and field keys. It will, however, assume that the double or
+  single quotes are part of the name, key, or value. This can complicate query
+  syntax (see the example below).
+
+
+Float IEEE-754 64-bit floating-point numbers. This is the default numerical
+     type. Examples: 1, 1.0, 1.e+78, 1.E+78.
+Integer Signed 64-bit integers (-9223372036854775808 to 9223372036854775807).
+     Specify an integer with a trailing i on the number. Example: 1i.
+
+For tag keys, tag values, and field keys always use a backslash character \ to
+escape:
+
+    commas ,
+    equal signs =
+    spaces
+
+For measurements always use a backslash character \ to escape:
+
+    commas ,
+    spaces
+
+For string field values use a backslash character \ to escape:
+
+    double quotes ""
+
+Line Protocol does not require users to escape the backslash character \. Users
+do not need to escape all other special characters.
+
+do not use any keywords:
+ALL           ALTER         ANY           AS            ASC           BEGIN
+BY            CREATE        CONTINUOUS    DATABASE      DATABASES     DEFAULT
+DELETE        DESC          DESTINATIONS  DIAGNOSTICS   DISTINCT      DROP
+DURATION      END           EVERY         EXPLAIN       FIELD         FOR
+FROM          GRANT         GRANTS        GROUP         GROUPS        IN
+INF           INSERT        INTO          KEY           KEYS          KILL
+LIMIT         SHOW          MEASUREMENT   MEASUREMENTS  NAME          OFFSET
+ON            ORDER         PASSWORD      POLICY        POLICIES      PRIVILEGES
+QUERIES       QUERY         READ          REPLICATION   RESAMPLE      RETENTION
+REVOKE        SELECT        SERIES        SET           SHARD         SHARDS
+SLIMIT        SOFFSET       STATS         SUBSCRIPTION  SUBSCRIPTIONS TAG
+TO            USER          USERS         VALUES        WHERE         WITH
+WRITE
+*)
+
+module P = struct
+  let tv (sec, usec) = Printf.sprintf "%Lu.%06d" sec usec
+
+  (* TODO: this should use an unsigned to string function *)
+  let i64 i = Int64.to_string i ^ "i"
+
+  let encode_ru vm ru =
+    let fields =
+      [ "utime", tv ru.utime ;
+        "stime", tv ru.stime ;
+        "maxrss", i64 ru.maxrss ;
+        "ixrss", i64 ru.ixrss ;
+        "idrss", i64 ru.idrss ;
+        "isrss", i64 ru.isrss ;
+        "minflt", i64 ru.minflt ;
+        "maxflt", i64 ru.majflt ;
+        "nswap", i64 ru.nswap ;
+        "inblock", i64 ru.inblock ;
+        "outblock", i64 ru.outblock ;
+        "msgsnd", i64 ru.msgsnd ;
+        "msgrcv", i64 ru.msgrcv ;
+        "nsignals", i64 ru.nsignals ;
+        "nvcsw", i64 ru.nvcsw ;
+        "nivcsw", i64 ru.nivcsw
+      ]
+    in
+    let fields = List.map (fun (k, v) -> k ^ "=" ^ v) fields in
+    Printf.sprintf "resource_usage,vm=%s %s" vm (String.concat ~sep:"," fields)
+
+  let encode_vmm vm xs =
+    let escape s =
+      let cutted = String.cuts ~sep:"," s in
+      let cutted = String.concat ~sep:"\\," cutted in
+      let cutted = String.cuts ~sep:" " cutted in
+      let cutted = String.concat ~sep:"\\ " cutted in
+      let cutted = String.cuts ~sep:"=" cutted in
+      String.concat ~sep:"\\=" cutted
+    in
+    Printf.sprintf "vmm,vm=%s %s" vm
+      (String.concat ~sep:","
+         (List.map (fun (k, v) -> (escape k) ^ "=" ^ (i64 v)) xs))
+
+  let i32 i = Int32.to_string i ^ "i"
+
+  let encode_if vm ifd =
+    let fields =
+    (* TODO: flags *)
+      [ "send_queue_length", i32 ifd.send_length ;
+        "max_send_queue_length", i32 ifd.max_send_length ;
+        "send_queue_drops", i32 ifd.send_drops ;
+        "mtu", i32 ifd.mtu ;
+        "baudrate", i64 ifd.baudrate ;
+        "vm_to_host_packets", i64 ifd.input_packets ;
+        "vm_to_host_errors", i64 ifd.input_errors ;
+        "vm_to_host_bytes", i64 ifd.input_bytes ;
+        "vm_to_host_mcast", i64 ifd.input_mcast ;
+        "vm_to_host_dropped", i64 ifd.input_dropped ;
+        "collisions", i64 ifd.collisions ;
+        "host_to_vm_packets", i64 ifd.output_packets ;
+        "host_to_vm_errors", i64 ifd.output_errors ;
+        "host_to_vm_bytes", i64 ifd.output_bytes ;
+        "host_to_vm_mcast", i64 ifd.output_mcast ;
+        "host_to_vm_dropped", i64 ifd.output_dropped
+      ]
+    in
+    let fields = List.map (fun (k, v) -> k ^ "=" ^ v) fields in
+    Printf.sprintf "interface,vm=%s,ifname=%s %s"
+      vm ifd.name (String.concat ~sep:"," fields)
+end
+
+let my_version = `WV1
+
+let command = ref 1
+
+let (req : string IM.t ref) = ref IM.empty
+
+let rec read_sock db c fd =
+  let open Vmm_wire in
+  Vmm_lwt.read_exactly c >>= function
+  | Error _ -> Lwt.return_unit
+  | Ok (hdr, data) ->
+    if not (version_eq hdr.version my_version) then begin
+      Logs.err (fun m -> m "unknown wire protocol version") ; Lwt.return_unit
+    end else
+      let name = IM.find hdr.id !req in
+      req := IM.remove hdr.id !req ;
+      match Stats.int_to_op hdr.tag with
+      | Some Stats.Stat_reply ->
+        begin match Vmm_wire.Stats.decode_stats (Cstruct.of_string data) with
+          | Error (`Msg msg) ->
+            Logs.warn (fun m -> m "couldn't decode stats for %s: %s" name msg) ;
+            read_sock db c fd
+          | Ok (ru, vmm, ifs) ->
+            let ru = P.encode_ru name ru in
+            let vmm = P.encode_vmm name vmm in
+            let taps = List.map (P.encode_if name) ifs in
+            let out = String.concat ~sep:"\n" (ru :: vmm :: taps @ [ "" ]) in
+            Logs.info (fun m -> m "result: %s" out) ;
+            Vmm_lwt.write_raw fd out >>= function
+            | Ok () -> read_sock db c fd
+            | Error _ -> invalid_arg "failed to write via TCP"
+        end
+      | _ when hdr.tag = fail_tag ->
+        Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ;
+        read_sock db c fd
+      | _ ->
+        Logs.err (fun m -> m "unhandled tag %d for %s" hdr.tag name) ;
+        read_sock db c fd
+
+let rec query_sock prefix db c interval =
+  (* query c for everyone in db *)
+  Lwt_list.iter_s (fun (id, name) ->
+      let id = identifier id in
+      let id = match prefix with None -> id | Some p -> p ^ "." ^ id in
+      let request = Vmm_wire.Stats.stat !command my_version id in
+      req := IM.add !command name !req ;
+      incr command ;
+      Vmm_lwt.write_raw c request >>= function
+      | Ok () -> Lwt.return_unit
+      | Error _ -> Lwt.fail_with "exception while writing")
+    db >>= fun () ->
+  Lwt_unix.sleep (float_of_int interval) >>= fun () ->
+  query_sock prefix db c interval
+
+let client stat_socket influxhost influxport db prefix interval =
+  (* start a socket connection to vmm_stats *)
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt.catch (fun () -> Lwt_unix.(connect c (ADDR_UNIX stat_socket)))
+    (fun e ->
+       Logs.warn (fun m -> m "error %s connecting to socket %s"
+                     (Printexc.to_string e) stat_socket) ;
+       invalid_arg "cannot connect to stat socket") >>= fun () ->
+
+  (* setup remote connection to influx *)
+  Lwt_unix.gethostbyname influxhost >>= fun host_entry ->
+  let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
+  let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in
+  Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ;
+  Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, influxport)) >>= fun () ->
+
+  (* loop *)
+  Lwt.join [ query_sock prefix db c interval ; read_sock db c fd ]
+
+let run_client _ socket (influxhost, influxport) db prefix interval =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  let db =
+    let open Rresult.R.Infix in
+    match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
+    | Ok [] -> invalid_arg "empty database"
+    | Ok db -> db
+    | Error (`Msg m) ->
+      invalid_arg ("couldn't parse database " ^ m)
+  in
+  Lwt_main.run (client socket influxhost influxport db prefix interval)
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let host_port : (string * int) Arg.converter =
+  let parse s =
+    match String.cut ~sep:":" s with
+    | None -> `Error "broken: no port specified"
+    | Some (hostname, port) ->
+      try
+        `Ok (hostname, int_of_string port)
+      with
+        Not_found -> `Error "failed to parse port"
+  in
+  parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
+
+let socket =
+  let doc = "Stat socket to connect onto" in
+  Arg.(required & pos 0 (some string) None & info [] ~doc)
+
+let influx =
+  Arg.(required & pos 1 (some host_port) None & info [] ~docv:"influx"
+         ~doc:"the influx hostname:port to connect to")
+
+let db =
+  let doc = "VMID database" in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let prefix =
+  let doc = "prefix" in
+  Arg.(value & opt (some string) None & info [ "prefix" ] ~doc)
+
+let interval =
+  let doc = "Poll interval in seconds" in
+  Arg.(value & opt int 10 & info [ "interval" ] ~doc)
+
+let cmd =
+  let doc = "VMM InfluxDB connector" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ]
+  in
+  Term.(pure run_client $ setup_log $ socket $ influx $ db $ prefix $ interval),
+  Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let () =
+  match Term.eval cmd
+  with `Error _ -> exit 1 | _ -> exit 0

app/vmm_log.ml

@@ -120,6 +120,9 @@ let jump _ file sock =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Lwt_main.run
     (Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
+     (Lwt_unix.file_exists sock >>= function
+       | true -> Lwt_unix.unlink sock
+       | false -> Lwt.return_unit) >>= fun () ->
      let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
      Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () ->
      Lwt_unix.listen s 1 ;
@@ -144,12 +147,13 @@ let setup_log =
         $ Logs_cli.level ())
 
 let socket =
-  let doc = "Socket to listen onto" in
+  let doc = "Socket to listen on" in
-  Arg.(required & pos 1 (some string) None & info [] ~doc)
+  let sock = Fpath.(to_string (Vmm_core.tmpdir / "log" + "sock")) in
+  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
 
 let file =
-  let doc = "File to write to" in
+  let doc = "File to write the log to" in
-  Arg.(required & pos 0 (some string) None & info [] ~doc)
+  Arg.(value & opt string "/var/log/albatross" & info [ "logfile" ] ~doc)
 
 let cmd =
   Term.(ret (const jump $ setup_log $ file $ socket)),

app/vmm_prometheus_stats.ml

@@ -343,10 +343,10 @@ let db =
   Arg.(value & opt (some file) None & info [ "db" ] ~doc)
 
 let cmd =
-  let doc = "VMM TLS client" in
+  let doc = "VMM Prometheus connector" in
   let man = [
     `S "DESCRIPTION" ;
-    `P "$(tname) connects to a server and initiates a TLS handshake" ]
+    `P "$(tname) connects to a VMMD to gather statistics and serves them for Prometheus via HTTP" ]
   in
   Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db $ address $ port),
   Term.info "vmm_prometheus_stats" ~version:"%%VERSION_NUM%%" ~doc ~man

app/vmmd.ml

@@ -216,16 +216,15 @@ let rec stats_loop () =
   Lwt_unix.sleep 600. >>= fun () ->
   stats_loop ()
 
-let jump _ dir cacert cert priv_key port =
+let jump _ cacert cert priv_key port =
   Sys.(set_signal sigpipe Signal_ignore) ;
-  let dir = Fpath.v dir in
   Lwt_main.run
     (Nocrypto_entropy_lwt.initialize () >>= fun () ->
-     (init_sock dir "cons" >|= function
+     (init_sock Vmm_core.tmpdir "cons" >|= function
        | None -> invalid_arg "cannot connect to console socket"
        | Some c -> c) >>= fun c ->
-     init_sock dir "stat" >>= fun s ->
+     init_sock Vmm_core.tmpdir "stat" >>= fun s ->
-     (init_sock dir "log" >|= function
+     (init_sock Vmm_core.tmpdir "log" >|= function
        | None -> invalid_arg "cannot connect to log socket"
        | Some l -> l) >>= fun l ->
      server_socket port >>= fun socket ->
@@ -237,7 +236,7 @@ let jump _ dir cacert cert priv_key port =
        Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
               ~reneg:true ~certificates:(`Single cert) ())
      in
-     (match Vmm_engine.init dir cmp_s c s l with
+     (match Vmm_engine.init cmp_s c s l with
       | Ok s -> Lwt.return s
       | Error (`Msg m) -> Lwt.fail_with m) >>= fun t ->
      let state = ref t in
@@ -289,28 +288,24 @@ let setup_log =
         $ Fmt_cli.style_renderer ()
         $ Logs_cli.level ())
 
-let wdir =
-  let doc = "Working directory (unix domain sockets, etc.)" in
-  Arg.(required & pos 0 (some dir) None & info [] ~doc)
-
 let cacert =
   let doc = "CA certificate" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
+  Arg.(required & pos 0 (some file) None & info [] ~doc)
 
 let cert =
   let doc = "Certificate" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
 
 let key =
   let doc = "Private key" in
-  Arg.(required & pos 3 (some file) None & info [] ~doc)
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
 
 let port =
   let doc = "TCP listen port" in
   Arg.(value & opt int 1025 & info [ "port" ] ~doc)
 
 let cmd =
-  Term.(ret (const jump $ setup_log $ wdir $ cacert $ cert $ key $ port)),
+  Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)),
   Term.info "vmmd" ~version:"%%VERSION_NUM%%"
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

pkg/pkg.ml

@@ -18,6 +18,6 @@ let () =
     Pkg.bin "provision/vmm_gen_ca" ;
     Pkg.clib "stats/libvmm_stats_stubs.clib" ;
     Pkg.bin "stats/vmm_stats_lwt" ;
-    Pkg.bin "stats/vmm_stats_once" ;
     Pkg.bin "app/vmm_prometheus_stats" ;
+    Pkg.bin "app/vmm_influxdb_stats" ;
   ]

src/vmm_commands.ml

@@ -49,7 +49,7 @@ let rec close fd =
 let close_no_err fd = try close fd with _ -> ()
 
 (* own code starts here
-   (c) 2017 Hannes Mehnert, all rights reserved *)
+   (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Vmm_core
 
@@ -58,9 +58,8 @@ let rec mkfifo name =
   | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
 
 let image_file, fifo_file =
-  let tmp = Fpath.v (Filename.get_temp_dir_name ()) in
+  ((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")),
-  ((fun vm -> Fpath.(tmp / (vm_id vm) + "img")),
+   (fun vm -> Fpath.(tmpdir / (vm_id vm) + "fifo")))
-   (fun vm -> Fpath.(tmp / (vm_id vm) + "fifo")))
 
 let rec fifo_exists file =
   try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
@@ -157,13 +156,13 @@ let cpuset cpu =
     Ok ([ "taskset" ; "-c" ; cpustring ])
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
-let exec dir vm taps =
+let exec vm taps =
   (* TODO: --net-mac=xx *)
   let net = List.map (fun t -> "--net=" ^ t) taps in
   let argv = match vm.argv with None -> [] | Some xs -> xs in
   (match taps with
-   | [] -> Ok Fpath.(dir / "ukvm-bin.none")
+   | [] -> Ok Fpath.(dbdir / "ukvm-bin.none")
-   | [_] -> Ok Fpath.(dir / "ukvm-bin.net")
+   | [_] -> Ok Fpath.(dbdir / "ukvm-bin.net")
    | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
   cpuset vm.cpuid >>= fun cpuset ->
   let mem = "--mem=" ^ string_of_int vm.requested_memory in

src/vmm_commands.mli

@@ -8,7 +8,7 @@ val prepare : vm_config -> (string list, [> R.msg ]) result
 
 val shutdown : vm -> (unit, [> R.msg ]) result
 
-val exec : Fpath.t -> vm_config -> string list -> (vm, [> R.msg ]) result
+val exec : vm_config -> string list -> (vm, [> R.msg ]) result
 
 val destroy : vm -> unit
 

src/vmm_core.ml

@@ -4,6 +4,9 @@ open Astring
 
 open Rresult.R.Infix
 
+let tmpdir = Fpath.(v "/var" / "run" / "albatross")
+let dbdir = Fpath.(v "/var" / "db" / "albatross")
+
 module I = struct
   type t = int
   let compare : int -> int -> int = compare

src/vmm_engine.ml

@@ -8,7 +8,6 @@ open Rresult
 open R.Infix
 
 type ('a, 'b, 'c) t = {
-  dir : Fpath.t ;
   cmp : 'b -> 'b -> bool ;
   console_socket : 'a ;
   console_counter : int ;
@@ -34,9 +33,9 @@ type ('a, 'b, 'c) t = {
   crls : X509.CRL.c list ;
 }
 
-let init dir cmp console_socket stats_socket log_socket =
+let init cmp console_socket stats_socket log_socket =
   (* error hard on permission denied etc. *)
-  let crls = Fpath.(dir / "crls") in
+  let crls = Fpath.(dbdir / "crls") in
   (Bos.OS.Dir.exists crls >>= function
     | true -> Ok true
     | false -> Bos.OS.Dir.create crls) >>= fun _ ->
@@ -49,14 +48,14 @@ let init dir cmp console_socket stats_socket log_socket =
        | None -> R.error_msgf "couldn't parse CRL %a" Fpath.pp f
        | Some crl -> Ok (crl :: acc))
     (Ok [])
-    Fpath.(dir / "crls") >>= fun crls ->
+    crls >>= fun crls ->
   crls >>= fun crls ->
   Ok {
-    dir ; cmp ;
+    cmp ;
     console_socket ; console_counter = 1 ; console_requests = IM.empty ;
     console_attached = String.Map.empty ; console_version = `WV0 ;
     stats_socket ; stats_counter = 1 ; stats_requests = IM.empty ;
-    stats_version = `WV0 ;
+    stats_version = `WV1 ;
     log_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
     log_version = `WV0 ; log_requests = IM.empty ;
     client_version = `WV0 ;
@@ -124,7 +123,7 @@ let handle_create t vm_config policies =
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
   Ok (fun t s ->
         (* actually execute the vm *)
-        Vmm_commands.exec t.dir vm_config taps >>= fun vm ->
+        Vmm_commands.exec vm_config taps >>= fun vm ->
         Logs.debug (fun m -> m "exec()ed vm") ;
         Vmm_resources.insert t.resources full vm >>= fun resources ->
         let used_bridges =
@@ -142,8 +141,8 @@ let handle_create t vm_config policies =
         Ok (t, `Tls (s, tls_out) :: out, vm))
 
 let setup_stats t vm =
-  Vmm_commands.setup_freebsd_kludge vm.Vmm_core.pid >>= fun () ->
+  Vmm_commands.setup_freebsd_kludge vm.pid >>= fun () ->
-  let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.pid vm.taps in
+  let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (vm_id vm.config) vm.pid vm.taps in
   let t = { t with stats_counter = succ t.stats_counter } in
   Ok (t, stat t stat_out)
 
@@ -167,7 +166,7 @@ let handle_shutdown t vm r =
         String.Map.add br (String.Set.remove ta old) b)
       t.used_bridges vm.config.network vm.taps
   in
-  let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.pid in
+  let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (vm_id vm.config) in
   let tasks = String.Map.remove (vm_id vm.config) t.tasks in
   let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges ; tasks } in
   let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname,
@@ -185,6 +184,7 @@ let handle_command t s prefix perms hdr buf =
         begin
           Vmm_wire.decode_str buf >>= fun (buf, _l) ->
           let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
+          let vmid = string_of_id arg in
           match x with
           | Info ->
             begin match Vmm_resources.find t.resources arg with
@@ -211,29 +211,27 @@ let handle_command t s prefix perms hdr buf =
             end
           | Attach ->
             (* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
-            let name = String.concat ~sep:"." arg in
             let on_success t =
-              let cons = Vmm_wire.Console.history t.console_counter t.console_version name Ptime.epoch in
+              let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
-              let old = match String.Map.find name t.console_attached with
+              let old = match String.Map.find vmid t.console_attached with
                 | None -> []
                 | Some s ->
                   let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
                   [ `Tls (s, out) ]
               in
-              let console_attached = String.Map.add name s t.console_attached in
+              let console_attached = String.Map.add vmid s t.console_attached in
               { t with console_counter = succ t.console_counter ; console_attached },
               `Raw (t.console_socket, cons) :: old
             in
-            let cons = Vmm_wire.Console.attach t.console_counter t.console_version name in
+            let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in
             let console_requests = IM.add t.console_counter on_success t.console_requests in
             Ok ({ t with console_counter = succ t.console_counter ; console_requests },
                 [ `Raw (t.console_socket, cons) ])
           | Detach ->
-            let name = String.concat ~sep:"." arg in
+            let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
-            let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in
+            (match String.Map.find vmid t.console_attached with
-            (match String.Map.find name t.console_attached with
              | None -> Error (`Msg "not attached")
-             | Some x when t.cmp x s -> Ok (String.Map.remove name t.console_attached)
+             | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached)
              | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached ->
             let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
             Ok ({ t with console_counter = succ t.console_counter ; console_attached },
@@ -243,7 +241,7 @@ let handle_command t s prefix perms hdr buf =
               | None -> Error (`Msg "no statistics available")
               | Some _ -> match Vmm_resources.find_vm t.resources arg with
                 | Some vm ->
-                  let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vm.pid in
+                  let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in
                   let d = (s, hdr.Vmm_wire.id, translate_tap vm) in
                   let stats_requests = IM.add t.stats_counter d t.stats_requests in
                   Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests },
@@ -326,7 +324,7 @@ let handle_revocation t s leaf chain ca prefix =
      | Some _, None -> Error (`Msg "CRL number not present")
      | Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
   (* filename should be whatever_dir / crls / <id> *)
-  let filename = Fpath.(t.dir / "crls" / string_of_id prefix) in
+  let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in
   Bos.OS.File.delete filename >>= fun () ->
   Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () ->
   (* remove crl with same issuer from crls, and inject this one into state *)

src/vmm_wire.ml

@@ -16,21 +16,26 @@ open Astring
 
 open Vmm_core
 
-type version = [ `WV0 ]
+type version = [ `WV0 | `WV1 ]
 
 let version_to_int = function
   | `WV0 -> 0
+  | `WV1 -> 1
 
 let version_of_int = function
   | 0 -> Ok `WV0
+  | 1 -> Ok `WV1
   | _ -> Error (`Msg "unknown wire version")
 
 let version_eq a b = match a, b with
   | `WV0, `WV0 -> true
+  | `WV1, `WV1 -> true
+  | _ -> false
 
 let pp_version ppf v =
   Fmt.string ppf (match v with
-      | `WV0 -> "wire version 0")
+      | `WV0 -> "wire version 0"
+      | `WV1 -> "wire version 1")
 
 type header = {
   length : int ;
@@ -243,16 +248,16 @@ module Stats = struct
     [@@uint16_t]
   ]
 
-  let encode id version op ?payload pid =
+  let encode id version op ?payload nam =
-    let pid = encode_pid pid in
+    let data, l = encode_string nam in
     let length, p =
       match payload with
-      | None -> 4, empty
+      | None -> l, empty
-      | Some x -> 4 + Cstruct.len x, x
+      | Some x -> l + Cstruct.len x, x
     and tag = op_to_int op
     in
     let r =
-      Cstruct.concat [ create_header { length ; version ; id ; tag } ; pid ; p ]
+      Cstruct.concat [ create_header { length ; version ; id ; tag } ; data ; p ]
     in
     Cstruct.to_string r
 
@@ -352,13 +357,13 @@ module Stats = struct
           output_mcast ; input_dropped ; output_dropped },
         l + 116)
 
-  let add id v pid taps =
+  let add id v nam pid taps =
-    let payload = encode_strings taps in
+    let payload = Cstruct.append (encode_pid pid) (encode_strings taps) in
-    encode id v Add ~payload pid
+    encode id v Add ~payload nam
 
-  let remove id v pid = encode id v Remove pid
+  let remove id v nam = encode id v Remove nam
 
-  let stat id v pid = encode id v Stat_request pid
+  let stat id v nam = encode id v Stat_request nam
 
   let stat_reply id version payload =
     let length = Cstruct.len payload

stats/vmm_stats.ml

@@ -16,7 +16,7 @@ external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close"
 external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames"
 external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats"
 
-let my_version = `WV0
+let my_version = `WV1
 
 let descr = ref []
 
@@ -25,12 +25,13 @@ type t = {
   pid_rusage : rusage IM.t ;
   pid_vmmapi : (string * int64) list IM.t ;
   nic_ifdata : ifdata String.Map.t ;
+  vmid_pid : int 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 }
+  { pid_nic = IM.empty ; pid_rusage = IM.empty ; pid_vmmapi = IM.empty ; nic_ifdata = String.Map.empty ; vmid_pid = String.Map.empty }
 
 let rec wrap f arg =
   try Some (f arg) with
@@ -91,7 +92,7 @@ let fill_descr ctx =
     end
   | ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds))
 
-let add_pid t pid nics =
+let add_pid t vmid pid nics =
   let name = "ukvm" ^ string_of_int pid in
   match wrap sysctl_ifcount () with
   | None ->
@@ -117,11 +118,17 @@ let add_pid t pid nics =
        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
+    let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic
-    Ok { t with pid_nic }
+    and vmid_pid = String.Map.add vmid pid t.vmid_pid
+    in
+    Ok { t with pid_nic ; vmid_pid }
 
 
-let stats t pid =
+let stats t vmid =
+  Logs.debug (fun m -> m "querying statistics for vmid %s" vmid) ;
+  match String.Map.find vmid t.vmid_pid with
+  | None -> Error (`Msg ("unknown vm " ^ vmid))
+  | Some pid ->
     Logs.debug (fun m -> m "querying statistics for %d" pid) ;
     try
       let _, nics = IM.find pid t.pid_nic
@@ -145,7 +152,11 @@ let stats t pid =
     with
     | _ -> Error (`Msg "failed to find resource usage")
 
-let remove_pid t pid =
+let remove_vmid t vmid =
+  Logs.info (fun m -> m "removing vmid %s" vmid) ;
+  match String.Map.find vmid t.vmid_pid with
+  | None -> Logs.warn (fun m -> m "no pid found for %s" vmid) ; t
+  | Some pid ->
     Logs.info (fun m -> m "removing pid %d" pid) ;
     (try
        match IM.find pid t.pid_nic with
@@ -153,11 +164,13 @@ let remove_pid t pid =
        | None, _ -> ()
      with
        _ -> ()) ;
-  let pid_nic = IM.remove pid t.pid_nic in
+    let pid_nic = IM.remove pid t.pid_nic
-  { t with pid_nic }
+    and vmid_pid = String.Map.remove vmid t.vmid_pid
+    in
+    { t with pid_nic ; vmid_pid }
 
-let remove_pids t pids =
+let remove_vmids t vmids =
-  List.fold_left remove_pid t pids
+  List.fold_left remove_vmid t vmids
 
 let handle t hdr buf =
   let open Vmm_wire in
@@ -167,18 +180,17 @@ let handle t hdr buf =
     if not (version_eq my_version hdr.version) then
       Error (`Msg "cannot handle version")
     else
+      decode_string cs >>= fun (name, off) ->
       match int_to_op hdr.tag with
       | Some Add ->
-        decode_pid_taps cs >>= fun (pid, taps) ->
+        decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) ->
-        add_pid t pid taps >>= fun t ->
+        add_pid t name pid taps >>= fun t ->
-        Ok (t, `Add pid, success ~msg:"added" hdr.id my_version)
+        Ok (t, `Add name, success ~msg:"added" hdr.id my_version)
       | Some Remove ->
-        decode_pid cs >>= fun pid ->
+        let t = remove_vmid t name in
-        let t = remove_pid t pid in
+        Ok (t, `Remove name, success ~msg:"removed" hdr.id my_version)
-        Ok (t, `Remove pid, success ~msg:"removed" hdr.id my_version)
       | Some Stat_request ->
-        decode_pid cs >>= fun pid ->
+        stats t name >>= fun s ->
-        stats t pid >>= fun s ->
         Ok (t, `None, stat_reply hdr.id my_version (encode_stats s))
       | _ -> Error (`Msg "unknown command")
   in

stats/vmm_stats_lwt.ml

@@ -41,10 +41,10 @@ let handle s addr () =
       | Ok () -> loop acc
       | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc
   in
-  loop [] >>= fun pids ->
+  loop [] >>= fun vmids ->
   Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
-  Logs.warn (fun m -> m "disconnect, dropping %d pids!" (List.length pids)) ;
+  Logs.warn (fun m -> m "disconnect, dropping %d vms!" (List.length vmids)) ;
-  let t' = Vmm_stats.remove_pids !t pids in
+  let t' = Vmm_stats.remove_vmids !t vmids in
   t := t'
 
 let rec timer interval () =
@@ -56,7 +56,10 @@ let jump _ file interval =
   Sys.(set_signal sigpipe Signal_ignore) ;
   let interval = Duration.(to_f (of_sec interval)) in
   Lwt_main.run
-    (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+    ((Lwt_unix.file_exists file >>= function
+       | true -> Lwt_unix.unlink file
+       | false -> Lwt.return_unit) >>= fun () ->
+     let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
      Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () ->
      Lwt_unix.listen s 1 ;
      Lwt.async (timer interval) ;
@@ -80,8 +83,9 @@ let setup_log =
         $ Logs_cli.level ())
 
 let socket =
-  let doc = "Socket to listen onto" in
+  let doc = "Socket to listen on" in
-  Arg.(value & pos 0 string "" & info [] ~doc)
+  let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in
+  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
 
 let interval =
   let doc = "Interval between statistics gatherings (in seconds)" in

stats/vmm_stats_once.ml

@@ -1,70 +0,0 @@
-(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
-
-(* the process responsible for gathering statistics (CPU + mem + network) *)
-
-open Lwt.Infix
-
-let t = ref (Vmm_stats.empty ())
-
-let rec timer pids () =
-  t := Vmm_stats.tick !t ;
-  List.iter (fun pid ->
-      match Vmm_stats.stats !t pid with
-      | Ok (ru, vmm, ifd) ->
-        Logs.info (fun m -> m "stats %d@.%a@.%a@.%a@."
-                      pid Vmm_core.pp_rusage ru
-                      Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
-                      Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifd)
-      | Error (`Msg e) ->
-        Logs.err (fun m -> m "error %s while getting stats of %d" e pid))
-    pids ;
-  Lwt_unix.sleep Duration.(to_f (of_sec 1)) >>= fun () ->
-  timer pids ()
-
-let split_pid xs =
-  List.fold_left (fun acc str ->
-      match Astring.String.cuts ~sep:":" str with
-      | pid :: taps -> (int_of_string pid, taps) :: acc
-      | [] -> invalid_arg "invalid pid") [] xs
-
-let jump _ pids =
-  Sys.(set_signal sigpipe Signal_ignore) ;
-  let pid_taps = split_pid pids in
-  let st =
-    List.fold_left (fun t (pid, taps) ->
-        match Vmm_stats.add_pid t pid taps with
-        | Ok t ->
-          Logs.info (fun m -> m "added pid %d taps %a"
-                        pid Fmt.(list ~sep:(unit ", ") string) taps) ;
-          t
-        | Error (`Msg ms) ->
-          Logs.err (fun m -> m "error %s while adding pid %d taps %a"
-                       ms pid Fmt.(list ~sep:(unit ", ") string) taps);
-          invalid_arg "broken")
-      !t pid_taps
-  in
-  t := st ;
-  let pids = fst (List.split pid_taps) in
-  `Ok (Lwt_main.run (timer pids ()))
-
-let setup_log style_renderer level =
-  Fmt_tty.setup_std_outputs ?style_renderer ();
-  Logs.set_level level;
-  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
-
-open Cmdliner
-
-let setup_log =
-  Term.(const setup_log
-        $ Fmt_cli.style_renderer ()
-        $ Logs_cli.level ())
-
-let pids =
-  let doc = "pids" in
-  Arg.(value & opt_all string [] & info [ "pid" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ pids)),
-  Term.info "vmm_stats_once" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1