Merge pull request #15 from hannesm/new-order

New order

.merlin

@@ -5,6 +5,6 @@ S provision
 
 B _build/**
 
-PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration
+PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex duration
 PKG ptime ptime.clock.os ipaddr.unix decompress
 PKG lwt.unix

.ocamlinit

@@ -0,0 +1,3 @@
+#require "cstruct, asn1-combinators, astring, fmt, ipaddr, rresult, lwt, x509, tls, hex, bos, decompress, tls.lwt"
+#directory "_build/src"
+#load "albatross.cma"

.travis.yml

@@ -7,8 +7,8 @@ env:
     - PACKAGE="albatross"
     - TESTS=false
   matrix:
-    - OCAML_VERSION=4.04
     - OCAML_VERSION=4.05
     - OCAML_VERSION=4.06
+    - OCAML_VERSION=4.07
 notifications:
   email: false

README.md

@@ -1,9 +1,22 @@
-# Albatross: Managing virtual machines
+# Albatross: orchestrate and manage MirageOS unikernels
 
 [![Build Status](https://travis-ci.org/hannesm/albatross.svg?branch=master)](https://travis-ci.org/hannesm/albatross)
 
-A set of binaries to manage, provision, and deploy virtual machine images.  This
-is very much work in progress, don't expect anything stable.
+A set of binaries to manage, provision, and deploy MirageOS unikernels.
+Some daemons are supposed to run in the host system, communicating via Unix domain sockets:
+- `vmmd`: privileged to create and destroy unikernels (also creates tap devices and attaches these to bridges)
+- `vmmd_console`: reads the console output of unikernels (via a fifo passed from `vmmd`)
+- `vmmd_log`: event log
+- `vmmd_stats`: statistics (`getrusage`, ifstat, BHyve debug counters) gathering
+- `vmmd_tls`: authenticates and proxies commands carried by a client certificate
+- `vmmd_influx`: reports statistics from stats to influx listener
+
+Command-line applications for local and remote management are provided as well
+- `vmmc_local`: executes a command locally via Unix domain sockets
+- `vmmc_remote`: connects to `vmm_tls_endpoint` and executes command
+- `vmmc_bistro`: command line utility to execute a command remotely: request, sign, remote (do not use in production, requires CA key on host)
+- `vmmp_request`: creates a certificate signing request containing a command
+- `vmmp_ca`: certificate authority operations: sign, generate (and revoke)
 
 Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
 and an overview.
@@ -14,13 +27,12 @@ is used on top to (more gracefully) handle multiple connection, and to have a
 watching thread (in `waitpid(2)`) for every virtual machine started by vmmd.
 
 To install Albatross, run `opam pin add albatross
-https://github.com/hannesm/albatross`.  On FreeBSD, `opam pin add
-solo5-kernel-ukvm --dev` is needed as well.
+https://github.com/hannesm/albatross`.
 
 The following elaborates on how to get the software up and running, following by
 provisioning and deploying some unikernels.  There is a *server* (`SRV`)
 component which needs six binaries: vmm_console, vmm_log, vmm_stats_lwt, vmmd,
-ukvm-bin.none, and ukvm-bin.net; a `CA` machine (which should be air-gapped, or
+solo6-hvt.none, and solo5-hvt.net; a `CA` machine (which should be air-gapped, or
 at least use some hardware token) for provisioning which needs vmm_sign, and
 vmm_gen_ca; and a *development* (`DEV`) machine which has a fully featured OCaml
 and MirageOS environment.  Each step is prefixed with the machine it is supposed
@@ -63,15 +75,15 @@ steps to produce the remaining required binaries:
 CA> COPY cacert.pem server.pem server.key SRV:
 DEV> git clone https://github.com/mirage/mirage-skeleton.git
 DEV> cd mirage-skeleton/tutorial/hello
-DEV> mirage configure -t ukvm
+DEV> mirage configure -t hvt
 DEV> mirage build
-DEV> mv ukvm-bin /tmp/ukvm-bin.none
-DEV> cd ../device-usage/network
-DEV> mirage configure -t ukvm
+DEV> mv solo5-hvt /tmp/solo5-hvt.none
+DEV> cd ../../device-usage/network
+DEV> mirage configure -t hvt
 DEV> mirage build
-DEV> mv ukvm-bin /tmp/ukvm-bin.net
+DEV> mv solo5-hvt /tmp/solo5-hvt.net
 DEV> cd ../../..
-DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:/var/db/albatross
+DEV> COPY /tmp/solo5-hvt.none /tmp/solo5-hvt.net SRV:/var/db/albatross
 DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:/opt/bin/
 ```
 
@@ -104,7 +116,7 @@ able to collect statistics unless running as a privileged user, the following
 
 ```
 [albatross=10]
-add path 'vmm/ukvm*' mode 0660 group albatross
+add path 'vmm/solo5*' mode 0660 group albatross
 ```
 
 Also need to activate by adding `devfs_system_ruleset="albatross"` to
@@ -140,12 +152,12 @@ This produced in the first step two files, `admin.req` and `admin.key`, and in
 the second step two more files, `dev.db` and `admin.pem`.
 
 ```
-DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.ukvm 12 1
+DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.hvt 12 1
 DEV> vmm_sign dev.db dev.pem dev.key hello.req
 ```
 
 This generates a private key `hello.key` and a certificate signing request named
-`hello.req` including the virtual machine image `hello.ukvm`, which gets 12MB
+`hello.req` including the virtual machine image `hello.hvt`, which gets 12MB
 memory and CPU id 1.  The second command used the `dev.key` to sign the signing
 request and output a `hello.pem`.
 

_tags

@@ -1,20 +1,25 @@
 true : bin_annot, safe_string, principal, color(always)
 true : warn(+A-4-44-48)
-true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct)
+true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decompress asn1-combinators)
 "src" : include
 
-<src/vmm_compress.ml>: package(decompress)
-<src/vmm_wire.{ml,mli}>: package(ppx_cstruct)
-<src/vmm_asn.{ml,mli}>: package(asn1-combinators)
 <src/vmm_lwt.{ml,mli}>: package(lwt lwt.unix)
-<src/vmm_tls.{ml,mli}>: package(lwt tls.lwt)
+<src/vmm_tls_lwt.{ml,mli}>: package(lwt tls.lwt)
+<src/vmm_tls.{ml,mli}>: package(x509)
+<src/vmm_vmmd.{ml,mli}>: package(ptime.clock.os)
 
-<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress)
-<app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
-<app/vmmd.{ml,native,byte}>: package(tls.lwt)
-<app/vmm_prometheus_stats.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
+<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix)
+<app/vmmd.{ml,native,byte}>: package(ptime.clock.os)
+<app/vmmd_console.{ml,native,byte}>: package(ptime.clock.os)
+<app/vmmd_log.{ml,native,byte}>: package(ptime.clock.os)
+<app/vmmd_tls.{ml,native,byte}>: package(tls.lwt ptime.clock.os)
+<app/vmmd_stats.{ml,native,byte}>: link_vmm_stats, package(asn1-combinators)
 
-<provision/*>: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress)
+<app/vmmc_remote.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
+<app/vmmc_bistro.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
+
+<app/vmmp_request.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
+<app/vmmp_ca.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
+
+<app/vmm_provision.{ml}>: package(nocrypto.unix ptime.clock.os x509)
 
-<stats/vmm_stats_lwt.{ml,native,byte}>: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress)
-<stats/vmm_stats_once.{ml,native,byte}>: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress)

app/vmm_cli.ml

@@ -0,0 +1,147 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Astring
+open Vmm_core
+
+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 ())
+
+let create_vm force image cpuid requested_memory argv block_device network compression =
+  let open Rresult.R.Infix in
+  (Bos.OS.File.read (Fpath.v image) >>= fun s ->
+   Ok (Cstruct.of_string s)) >>| fun image ->
+  let vmimage = match compression with
+    | 0 -> `Hvt_amd64, image
+    | level ->
+      let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
+      `Hvt_amd64_compressed, Cstruct.of_string img
+  and argv = match argv with [] -> None | xs -> Some xs
+  in
+  let vm_config = { cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in
+  if force then `Vm_force_create vm_config else `Vm_create vm_config
+
+let policy vms memory cpus block bridges =
+  let bridges = match bridges with
+    | xs ->
+      let add m v =
+        let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+        String.Map.add n v m
+      in
+      List.fold_left add String.Map.empty xs
+  and cpuids = IS.of_list cpus
+  in
+  { vms ; cpuids ; memory ; block ; bridges }
+
+
+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 Astring.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 bridge =
+  let parse s =
+    match Astring.String.cuts ~sep:"/" s with
+    | [ name ; fst ; lst ; gw ; nm ] ->
+      begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
+        | Some fst, Some lst, Some gw ->
+          (try
+             let nm = int_of_string nm in
+             if nm > 0 && nm <= 32 then
+               let net = Ipaddr.V4.Prefix.make nm gw in
+               if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
+                 `Ok (`External (name, fst, lst, gw, nm))
+               else
+                 `Error "first or last IP are not in subnet"
+             else
+               `Error "netmask must be > 0 and <= 32"
+           with Failure _ -> `Error "couldn't parse netmask")
+        | _ -> `Error "couldn't parse IP address"
+      end
+    | [ name ] -> `Ok (`Internal name)
+    | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
+  in
+  (parse, pp_bridge)
+
+let vm_c =
+  let parse s = `Ok (id_of_string s)
+  in
+  (parse, pp_id)
+
+let opt_vm_name =
+  let doc = "name of virtual machine." in
+  Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
+
+let compress_level =
+  let doc = "Compression level (0 for no compression)" in
+  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
+
+let force =
+  let doc = "force VM creation." in
+  Arg.(value & flag & info [ "f" ; "force" ] ~doc)
+
+let cpus =
+  let doc = "CPUs to allow" in
+  Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
+
+let vms =
+  let doc = "Number of VMs to allow" in
+  Arg.(required & pos 0 (some int) None & info [] ~doc)
+
+let block_size =
+  let doc = "Block storage to allow" in
+  Arg.(value & opt (some int) None & info [ "block" ] ~doc)
+
+let mem =
+  let doc = "Memory to allow" in
+  Arg.(value & opt int 512 & info [ "mem" ] ~doc)
+
+let bridge =
+  let doc = "Bridge to allow" in
+  Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
+
+let cpu =
+  let doc = "CPUid" in
+  Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
+
+let vm_mem =
+  let doc = "Memory to assign" in
+  Arg.(value & opt int 32 & info [ "mem" ] ~doc)
+
+let args =
+  let doc = "Boot arguments" in
+  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
+
+let block =
+  let doc = "Block device name" in
+  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
+
+let net =
+  let doc = "Network device" in
+  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+
+let timestamp_c =
+  let parse s = match Ptime.of_rfc3339 s with
+    | Ok (t, _, _) -> `Ok t
+    | Error _ -> `Error "couldn't parse timestamp"
+  in
+  (parse, Ptime.pp_rfc3339 ())
+
+let since =
+  let doc = "Since" in
+  Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)

app/vmm_client.ml

@@ -1,189 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Lwt.Infix
-
-open Vmm_core
-
-let my_version = `WV0
-let command = ref 1
-
-let process db hdr data =
-  let open Vmm_wire in
-  let open Rresult.R.Infix in
-  if not (version_eq hdr.version my_version) then
-    Logs.err (fun m -> m "unknown wire protocol version")
-  else
-    let r =
-      match hdr.tag with
-      | x when x = Client.stat_msg_tag ->
-        Client.decode_stat data >>= fun (ru, vmm, ifd) ->
-        Logs.app (fun m -> m "statistics: %a %a %a"
-                     pp_rusage ru
-                     Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm
-                     Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ;
-        Ok ()
-      | x when x = Client.log_msg_tag ->
-        Client.decode_log data >>= fun log ->
-        Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ;
-        Ok ()
-      | x when x = Client.console_msg_tag ->
-        Client.decode_console data >>= fun (name, ts, msg) ->
-        Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ;
-        Ok ()
-      | x when x = Client.info_msg_tag ->
-        Client.decode_info data >>= fun vms ->
-        List.iter (fun (name, cmd, pid, taps) ->
-            Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name)
-                         cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
-          vms ;
-        Ok ()
-      | x when x = fail_tag ->
-        decode_str data >>= fun (msg, _) ->
-        Logs.err (fun m -> m "failed %s" msg) ;
-        Ok ()
-      | x when x = success_tag ->
-        decode_str data >>= fun (msg, _) ->
-        Logs.app (fun m -> m "success %s" msg) ;
-        Ok ()
-      | x -> Rresult.R.error_msgf "unknown header tag %02X" x
-    in
-    match r with
-    | Ok () -> ()
-    | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg)
-
-let rec read_tls_write_cons db t =
-  Vmm_tls.read_tls t >>= function
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "error while reading %s" msg) ;
-    read_tls_write_cons db t
-  | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
-  | Ok (hdr, data) ->
-    process db hdr data ;
-    read_tls_write_cons db t
-
-let rec read_cons_write_tls db t =
-  Lwt.catch (fun () ->
-      Lwt_io.read_line Lwt_io.stdin >>= fun line ->
-      let cmd, arg = match Astring.String.cut ~sep:" " line with
-        | None -> line, None
-        | Some (a, b) -> a, Some (translate_name db b)
-      in
-      match Vmm_core.cmd_of_string cmd with
-      | None -> Logs.err (fun m -> m "unknown command") ; read_cons_write_tls db t
-      | Some cmd ->
-        let out = Vmm_wire.Client.cmd ?arg cmd !command my_version in
-        command := succ !command ;
-        Vmm_tls.write_tls t out >>= function
-        | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit
-        | Ok () ->
-          Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
-          read_cons_write_tls db t)
-    (fun e ->
-       Logs.err (fun m -> m "exception %s in read_cons_write_tls" (Printexc.to_string e)) ;
-       Lwt.return_unit)
-
-let client cas host port cert priv_key db =
-  Nocrypto_entropy_lwt.initialize () >>= fun () ->
-  let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
-  X509_lwt.authenticator auth >>= fun authenticator ->
-  Lwt.catch (fun () ->
-    Lwt_unix.gethostbyname host >>= 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.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
-    X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
-    (match fst cert with
-     | [] -> Lwt.fail_with "certificate is empty"
-     | hd::_ -> Lwt.return hd) >>= fun leaf ->
-    let certificates = `Single cert in
-    let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
-    Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
-
-    if Vmm_asn.contains_vm leaf || Vmm_asn.contains_crl leaf then
-      read_tls_write_cons db t
-    else
-      (Logs.debug (fun m -> m "read/write games!") ;
-       Lwt.join [ read_tls_write_cons db t ; read_cons_write_tls db t ]))
-    (fun exn ->
-       Logs.err (fun m -> m "failed to establish TLS connection: %s"
-                    (Printexc.to_string exn)) ;
-       Lwt.return_unit)
-
-let run_client _ cas cert key (host, port) db =
-  Printexc.register_printer (function
-      | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
-      | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
-      | _ -> None) ;
-  Sys.(set_signal sigpipe Signal_ignore) ;
-  let db =
-    let open Rresult.R.Infix in
-    match db with
-    | None -> []
-    | Some db ->
-      match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
-      | Ok db -> db
-      | Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; []
-  in
-  Lwt_main.run (client cas host port cert key db)
-
-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 =
-    try
-      let open String in
-      let colon = index s ':' in
-      let hostname = sub s 0 colon
-      and port =
-        let csucc = succ colon in
-        sub s csucc (length s - csucc)
-      in
-      `Ok (hostname, int_of_string port)
-    with
-      Not_found -> `Error "broken"
-  in
-  parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
-
-let cas =
-  let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
-  Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
-
-let client_cert =
-  let doc = "Use a client certificate chain" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let client_key =
-  let doc = "Use a client key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let destination =
-  Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
-         ~doc:"the destination hostname:port to connect to")
-
-let db =
-  let doc = "Certificate database" in
-  Arg.(value & opt (some file) None & info [ "db" ] ~doc)
-
-let cmd =
-  let doc = "VMM TLS client" in
-  let man = [
-    `S "DESCRIPTION" ;
-    `P "$(tname) connects to a server and initiates a TLS handshake" ]
-  in
-  Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db),
-  Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man
-
-let () =
-  match Term.eval cmd
-  with `Error _ -> exit 1 | _ -> exit 0

app/vmm_console.ml

@@ -1,188 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-(* the process responsible for buffering console IO *)
-
-(* communication channel is a single unix domain socket shared between vmmd and
-   vmm_console.  The vmmd can issue the following commands:
-    - Add name --> creates a new console slurper for name
-    - Attach name since --> attaches console of name since counter, whenever
-       console output to name is reported, this will be forwarded as Data
-    - Detach name --> detaches console *)
-
-open Lwt.Infix
-
-open Astring
-
-open Vmm_wire
-open Vmm_wire.Console
-
-let my_version = `WV0
-
-let pp_sockaddr ppf = function
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
-                                         (Unix.string_of_inet_addr addr) port
-
-let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
-
-let active = ref String.Map.empty
-
-let read_console name ring channel () =
-  Lwt.catch (fun () ->
-      let rec loop () =
-        Lwt_io.read_line channel >>= fun line ->
-        Logs.debug (fun m -> m "read %s" line) ;
-        let t = Ptime_clock.now () in
-        Vmm_ring.write ring (t, line) ;
-        (match String.Map.find name !active with
-         | None -> Lwt.return_unit
-         | Some fd ->
-           Vmm_lwt.write_raw fd (data my_version name t line) >>= function
-           | Error _ -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
-           | Ok () -> Lwt.return_unit) >>=
-        loop
-      in
-      loop ())
-    (fun e ->
-       begin match e with
-         | Unix.Unix_error (e, f, _) ->
-           Logs.err (fun m -> m "%s error in %s: %a" name f pp_unix_error e)
-         | End_of_file ->
-           Logs.debug (fun m -> m "%s end of file while reading" name)
-         | exn ->
-           Logs.err (fun m -> m "%s error while reading %s" name (Printexc.to_string exn))
-       end ;
-       Lwt_io.close channel)
-
-let open_fifo name =
-  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 ->
-      Lwt.return (Some channel))
-    (function
-      | Unix.Unix_error (e, f, _) ->
-        Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
-        Lwt.return None
-      | exn ->
-        Logs.err (fun m -> m "%a error while reading %s" Fpath.pp fifo (Printexc.to_string exn)) ;
-        Lwt.return None)
-
-let t = ref String.Map.empty
-
-let add_fifo name =
-  open_fifo name >|= function
-  | Some f ->
-    let ring = Vmm_ring.create () in
-    Logs.debug (fun m -> m "inserting %s" name) ;
-    let map = String.Map.add name ring !t in
-    t := map ;
-    Lwt.async (read_console name ring f) ;
-    Ok "reading"
-  | None ->
-    Error (`Msg "opening")
-
-let attach s name =
-  Logs.debug (fun m -> m "attempting to attach %s" name) ;
-  match String.Map.find name !t with
-  | None -> Lwt.return (Error (`Msg "not found"))
-  | Some _ ->
-    active := String.Map.add name s !active ;
-    Lwt.return (Ok "attached")
-
-let detach name =
-  active := String.Map.remove name !active ;
-  Lwt.return (Ok "removed")
-
-let history s name since =
-  match String.Map.find name !t with
-  | None -> Lwt.return (Rresult.R.error_msgf "ring %s not found (%d): %a"
-                          name (String.Map.cardinal !t)
-                          Fmt.(list ~sep:(unit ";") string)
-                          (List.map fst (String.Map.bindings !t)))
-  | Some r ->
-    let entries = Vmm_ring.read_history r since in
-    Logs.debug (fun m -> m "found %d history" (List.length entries)) ;
-    Lwt_list.iter_s (fun (i, v) ->
-        Vmm_lwt.write_raw s (data my_version name i v) >|= fun _ -> ())
-      entries >|= fun () ->
-    Ok "success"
-
-let handle s addr () =
-  Logs.info (fun m -> m "handling connection %a" pp_sockaddr addr) ;
-  let rec loop () =
-    Vmm_lwt.read_exactly s >>= function
-    | Error (`Msg msg) ->
-      Logs.err (fun m -> m "error while reading %s" msg) ;
-      loop ()
-    | Error _ ->
-      Logs.err (fun m -> m "exception while reading") ;
-      Lwt.return_unit
-    | Ok (hdr, data) ->
-      (if not (version_eq hdr.version my_version) then
-         Lwt.return (Error (`Msg "ignoring data with bad version"))
-       else
-         match decode_str data with
-         | Error e -> Lwt.return (Error e)
-         | Ok (name, off) ->
-           match Console.int_to_op hdr.tag with
-           | Some Add_console -> add_fifo name
-           | Some Attach_console -> attach s name
-           | Some Detach_console -> detach name
-           | Some History ->
-             (match decode_ts ~off data with
-              | Error e -> Lwt.return (Error e)
-              | Ok since -> history s name since)
-           | _ ->
-             Lwt.return (Error (`Msg "unknown command"))) >>= (function
-          | Ok msg -> Vmm_lwt.write_raw s (success ~msg hdr.id my_version)
-          | Error (`Msg msg) ->
-            Logs.err (fun m -> m "error while processing command: %s" msg) ;
-            Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= function
-      | Ok () -> loop ()
-      | Error _ ->
-        Logs.err (fun m -> m "exception while writing to socket") ;
-        Lwt.return_unit
-  in
-  loop () >>= fun () ->
-  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) ;
-  Lwt_main.run
-    ((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 () =
-       Lwt_unix.accept s >>= fun (cs, addr) ->
-       Lwt.async (handle cs addr) ;
-       loop ()
-     in
-     loop ())
-
-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 socket =
-  let doc = "Socket to listen on" in
-  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)),
-  Term.info "vmm_console" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmm_log.ml

@@ -1,162 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-(* the process responsible for event log *)
-
-(* communication channel is a single unix domain socket shared between vmmd and
-   vmm_log.  There are two commands from vmmd to vmm_log, history and data. *)
-
-(* TODO: this should (optionally?) persist to a remote target *)
-
-(* internally, a ring buffer for the last N events is preserved in memory
-   each new event is directly written to disk! *)
-
-open Lwt.Infix
-
-open Astring
-
-open Vmm_wire
-open Vmm_wire.Log
-
-let my_version = `WV0
-
-let write_complete s str =
-  let l = String.length str in
-  let b = Bytes.unsafe_of_string str in
-  let rec w off =
-    let len = l - off in
-    Lwt_unix.write s b off len >>= fun n ->
-    if n = len then Lwt.return_unit else w (off + n)
-  in
-  w 0
-
-let pp_sockaddr ppf = function
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
-                                         (Unix.string_of_inet_addr addr) port
-
-let handle fd ring s addr () =
-  Logs.info (fun m -> m "handling connection from %a" pp_sockaddr addr) ;
-  let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ~tz_offset_s:0 ()) (Ptime_clock.now ()) in
-  write_complete fd str >>= fun () ->
-  let rec loop () =
-    Vmm_lwt.read_exactly s >>= function
-    | Error (`Msg e) ->
-      Logs.err (fun m -> m "error while reading %s" e) ;
-      loop ()
-    | Error _ ->
-      Logs.err (fun m -> m "exception while reading") ;
-      Lwt.return_unit
-    | Ok (hdr, data) ->
-      let out =
-        (if not (version_eq hdr.version my_version) then
-           Error (`Msg "unknown version")
-         else match int_to_op hdr.tag with
-           | Some Data ->
-             (match decode_ts data with
-              | Ok ts -> Vmm_ring.write ring (ts, data)
-              | Error _ ->
-                Logs.warn (fun m -> m "ignoring error while decoding timestamp %s" data)) ;
-             Ok (`Data data)
-           | Some History ->
-             begin match decode_str data with
-               | Error e -> Error e
-               | Ok (str, off) -> match decode_ts ~off data with
-                 | Error e -> Error e
-                 | Ok ts ->
-                   let elements = Vmm_ring.read_history ring ts in
-                   let res = List.fold_left (fun acc (_, x) ->
-                       match Vmm_wire.Log.decode_log_hdr (Cstruct.of_string x) with
-                       | Ok (hdr, _) ->
-                         Logs.debug (fun m -> m "found an entry: %a" (Vmm_core.Log.pp_hdr []) hdr) ;
-                         if String.equal str (Vmm_core.string_of_id hdr.Vmm_core.Log.context) then
-                           x :: acc
-                         else
-                           acc
-                       | _ -> acc)
-                       [] elements
-                   in
-                   (* just need a wrapper in tag = Log.Data, id = reqid *)
-                   let out =
-                     List.fold_left (fun acc x ->
-                         let length = String.length x in
-                         let hdr = Vmm_wire.create_header { length ; id = hdr.id ; tag = op_to_int Data ; version = my_version } in
-                         (Cstruct.to_string hdr ^ x) :: acc)
-                       [] (List.rev res)
-                   in
-                   Ok (`Out out)
-             end
-           | _ -> Error (`Msg "unknown command"))
-      in
-      match out with
-      | Error (`Msg msg) ->
-        begin
-          Logs.err (fun m -> m "error while processing: %s" msg) ;
-          Vmm_lwt.write_raw s (fail ~msg hdr.id my_version) >>= function
-          | Error _ -> Logs.err (fun m -> m "error0 while writing") ; Lwt.return_unit
-          | Ok () -> loop ()
-        end
-      | Ok (`Data data) ->
-        begin
-          write_complete fd data >>= fun () ->
-          Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
-          | Error _ -> Logs.err (fun m -> m "error1 while writing") ; Lwt.return_unit
-          | Ok () -> loop ()
-        end
-      | Ok (`Out datas) ->
-        Lwt_list.fold_left_s (fun r x -> match r with
-            | Error e -> Lwt.return (Error e)
-            | Ok () -> Vmm_lwt.write_raw s x)
-          (Ok ()) datas >>= function
-        | Error _ -> Logs.err (fun m -> m "error2 while writing") ; Lwt.return_unit
-        | Ok () ->
-          Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
-          | Error _ -> Logs.err (fun m -> m "error3 while writing") ; Lwt.return_unit
-          | Ok () -> loop ()
-  in
-  loop () >>= fun () ->
-  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit)
-
-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 ;
-     let ring = Vmm_ring.create () in
-     let rec loop () =
-       Lwt_unix.accept s >>= fun (cs, addr) ->
-       Lwt.async (handle fd ring cs addr) ;
-       loop ()
-     in
-     loop ())
-
-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 socket =
-  let doc = "Socket to listen on" in
-  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 the log to" in
-  Arg.(value & opt string "/var/log/albatross" & info [ "logfile" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ file $ socket)),
-  Term.info "vmm_log" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmm_prometheus_stats.ml

@@ -1,356 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Lwt.Infix
-
-open Astring
-
-open Vmm_core
-
-let my_version = `WV0
-
-let command = ref 1
-
-let t : (Lwt_unix.file_descr * Lwt_unix.sockaddr * string) IM.t ref = ref IM.empty
-
-module S = struct
-  type t = Lwt_unix.sockaddr
-  let compare : Lwt_unix.sockaddr -> Lwt_unix.sockaddr -> int = compare
-end
-
-module SM = Map.Make(S)
-
-let count : int SM.t ref = ref SM.empty
-
-let dec s =
-  match SM.find s !count with
-  | exception Not_found -> `Not_found
-  | 1 -> count := SM.remove s !count ; `Close
-  | x -> count := SM.add s (pred x) !count ; `Continue
-
-let known_vms : string list ref = ref []
-
-module P = struct
-  let p vm ?(typ = `Counter) name help value =
-    let t_s = function `Counter -> "counter" | `Gauge -> "gauge" in
-    let name = vm ^ "_" ^ name in
-    let p a v = String.concat ~sep:" " [ "#" ; a ; name ; v ] in
-    String.concat ~sep:"\n"
-      [ p "HELP" help ; p "TYPE" (t_s typ) ; name ^ " " ^ value ]
-
-  let tv (sec, usec) = Printf.sprintf "%Lu.%06d" sec usec
-  let i64 i = Printf.sprintf "%Lu" i
-
-  let encode_ru vm ru =
-    let p = p vm in
-    String.concat  ~sep:"\n"
-      [ p "utime" "user time used" (tv ru.utime) ;
-        p "stime" "system time used" (tv ru.stime) ;
-        p "maxrss" "maximum resident set" (i64 ru.maxrss) ;
-        p ~typ:`Gauge "ixrss" "shared memory" (i64 ru.ixrss) ;
-        p ~typ:`Gauge "idrss" "unshared data" (i64 ru.idrss) ;
-        p ~typ:`Gauge "isrss" "unshared stack" (i64 ru.isrss) ;
-        p "minflt" "page reclaims" (i64 ru.minflt) ;
-        p "maxflt" "page faults" (i64 ru.majflt) ;
-        p "nswap" "swaps" (i64 ru.nswap) ;
-        p "inblock" "block input ops" (i64 ru.inblock) ;
-        p "outblock" "block output ops" (i64 ru.outblock) ;
-        p "msgsnd" "messages send" (i64 ru.msgsnd) ;
-        p "msgrcv" "messages received" (i64 ru.msgrcv) ;
-        p "nsignals" "signals received" (i64 ru.nsignals) ;
-        p "nvcsw" "voluntary context switches" (i64 ru.nvcsw) ;
-        p "nivcsw" "involuntary context switches" (i64 ru.nivcsw)
-      ]
-
-  let encode_vmm vm xs =
-    let p = p vm in
-    let massage s =
-      let cutted = match String.cut ~sep:"umber of " s with
-        | Some (_, r) -> r
-        | None -> s
-      in
-      let cutted = match String.cut ~sep:"[" cutted with
-        | None -> cutted
-        | Some (l, r) -> match String.cut ~sep:"]" r with
-          | None -> cutted
-          | Some (l', r) when r = "" -> l ^ "_" ^ l'
-          | Some (l', r') -> l ^ "_" ^ l' ^ "_" ^ r'
-      in
-      let cutted =
-        List.fold_left (fun str sep ->
-          match String.cut ~sep str with
-          | None -> str
-          | Some (l, r) -> l ^ r)
-        cutted [ "%" ; "/" ; "-" ]
-      in
-      String.concat ~sep:"_" (String.cuts ~sep:" " cutted)
-    in
-    String.concat ~sep:"\n"
-      (List.map (fun (k, v) -> p (massage k) k (i64 v)) xs)
-
-  let i32 i = Printf.sprintf "%lu" i
-
-  let encode_if vm ifd =
-    let p = p (vm ^ "_" ^ ifd.name) in
-    String.concat  ~sep:"\n"
-      (* TODO: flags *)
-      [ p ~typ:`Gauge "send_length" "length of send queue" (i32 ifd.send_length) ;
-        p "max_send_length" "maximum length of send queue" (i32 ifd.max_send_length) ;
-        p "send_drops" "drops in send queue" (i32 ifd.send_drops) ;
-        p ~typ:`Gauge "mtu" "maximum transmission unit" (i32 ifd.mtu) ;
-        p ~typ:`Gauge "baudrate" "linespeed" (i64 ifd.baudrate) ;
-        p "vm_to_host_packets" "packets from vm" (i64 ifd.input_packets) ;
-        p "vm_to_host_errors" "packet errors from vm" (i64 ifd.input_errors) ;
-        p "vm_to_host_bytes" "bytes from vm" (i64 ifd.input_bytes) ;
-        p "vm_to_host_mcast" "packets from vm via multicast" (i64 ifd.input_mcast) ;
-        p "vm_to_host_dropped" "packets dropped from vm" (i64 ifd.input_dropped) ;
-        p "collisions" "collisions on csma interface" (i64 ifd.collisions) ;
-        p "host_to_vm_packets" "packets to vm" (i64 ifd.output_packets) ;
-        p "host_to_vm_errors" "packet errors to vm" (i64 ifd.output_errors) ;
-        p "host_to_vm_bytes" "bytes to vm" (i64 ifd.output_bytes) ;
-        p "host_to_vm_mcast" "packets to vm via multicast" (i64 ifd.output_mcast) ;
-        p "host_to_vm_dropped" "packets dropped to vm" (i64 ifd.output_dropped)
-      ]
-end
-
-(* just a reminder whether we already sent the initial "info" or not *)
-let f_done = ref false
-
-let process db tls hdr data =
-  let open Vmm_wire in
-  let open Rresult.R.Infix in
-  if not (version_eq hdr.version my_version) then begin
-    Logs.err (fun m -> m "unknown wire protocol version") ; Lwt.return_unit
-  end else
-    match hdr.tag with
-    | x when x = Client.log_msg_tag && not !f_done ->
-      f_done := true ;
-      (* issue initial "info" to get all the vm names *)
-      let out = Vmm_wire.Client.cmd Info !command my_version in
-      command := succ !command ;
-      Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
-      (Vmm_tls.write_tls tls out >|= function
-        | Ok () -> ()
-        | Error _ -> Logs.err (fun m -> m "error while writing") ; ())
-    | _ ->
-      let r =
-        match hdr.tag with
-        | x when x = Client.log_msg_tag ->
-          Client.decode_log data >>= fun (hdr, event) ->
-          let nam = translate_serial db hdr.Vmm_core.Log.name in
-          begin match event with
-            | `VM_start _ -> known_vms := nam :: !known_vms
-            | `VM_stop _ -> known_vms := List.filter (fun m -> m <> nam) !known_vms
-            | _ -> ()
-          end ;
-          Ok `None
-        | x when x = Client.info_msg_tag ->
-          Client.decode_info data >>= fun vms ->
-          let vms = List.map (fun (name, _, _, _) -> translate_serial db name) vms in
-          known_vms := vms ;
-          Ok `None
-        | x when x = Client.stat_msg_tag ->
-          Client.decode_stat data >>= fun (ru, vmm, ifd) ->
-          begin match IM.find hdr.id !t with
-            | exception Not_found -> Logs.err (fun m -> m "unexpected reply") ; Ok `None
-            | (fd, s, vm) ->
-              t := IM.remove hdr.id !t ;
-              let out = String.concat ~sep:"\n" (P.encode_ru vm ru :: P.encode_vmm vm vmm :: List.map (P.encode_if vm) ifd @ [""]) in
-              Ok (`Stat (fd, s, out))
-          end
-        | x when x = fail_tag ->
-          let res =
-            match IM.find hdr.id !t with
-            | exception Not_found -> `None
-            | (fd, s, _) -> `Sockaddr (fd, s)
-          in
-          t := IM.remove hdr.id !t ;
-          decode_str data >>= fun (msg, _) ->
-          Logs.err (fun m -> m "failed %s" msg) ;
-          Ok res
-        | x -> Rresult.R.error_msgf "ignoring header tag %02X" x
-      in
-      let d (fd, s) = match dec s with
-        | `Continue -> Lwt.return_unit
-        | `Close -> Lwt_unix.close fd
-        | `Not_found -> Logs.err (fun m -> m "sockaddr not found") ; Lwt.return_unit
-      in
-      let open Lwt.Infix in
-      match r with
-      | Ok `None -> Lwt.return_unit
-      | Ok (`Sockaddr s) -> d s
-      | Ok (`Stat (fd, s, out)) ->
-        (Vmm_lwt.write_raw fd out >>= function
-          | Ok () -> d (fd, s)
-          | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit)
-      | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) ; Lwt.return_unit
-
-let rec tls_listener db tls =
-  (Vmm_tls.read_tls tls >>= function
-    | Error (`Msg msg) ->
-      Logs.err (fun m -> m "error while reading %s" msg) ;
-      Lwt.return (Ok ())
-    | Error _ ->
-      Logs.err (fun m -> m "received exception in read_tls") ;
-      Lwt.return (Error ())
-    | Ok (hdr, data) ->
-      process db tls hdr data >>= fun () ->
-      Lwt.return (Ok ())) >>= function
-  | Ok () -> tls_listener db tls
-  | Error () -> Lwt.return_unit
-
-let hdr =
-  String.concat ~sep:"\r\n"
-    [ "HTTP/1.1 200 OK" ;
-      "Content-Type: text/plain; version=0.0.4" ;
-      "\r\n" ]
-
-(* wait for TCP connection, once received request stats from vmmd, and loop *)
-let rec tcp_listener db tcp tls =
-  Lwt_unix.accept tcp >>= fun (cs, sockaddr) ->
-  Vmm_lwt.write_raw cs hdr >>= function
-  | Error _ -> Logs.err (fun m -> m "exception while accepting") ; Lwt.return_unit
-  | Ok () ->
-    let l = List.length !known_vms in
-    let ip, port = match sockaddr with Lwt_unix.ADDR_INET (ip, port) -> ip, port | _ -> invalid_arg "unexpected" in
-    Logs.info (fun m -> m "connection from %s:%d with %d known" (Unix.string_of_inet_addr ip) port l) ;
-    (if l = 0 then
-       Lwt_unix.close cs >|= fun () -> Error ()
-     else begin
-       count := SM.add sockaddr (List.length !known_vms) !count ;
-       Lwt_list.fold_left_s
-         (fun r vm ->
-            match r with
-            | Error () -> Lwt.return (Error ())
-            | Ok () ->
-              let vm_id = translate_name db vm in
-              let out = Vmm_wire.Client.cmd Statistics ~arg:vm_id !command my_version in
-              t := IM.add !command (cs, sockaddr, vm) !t ;
-              command := succ !command ;
-              Vmm_tls.write_tls tls out >|= function
-              | Ok () -> Ok ()
-              | Error _ -> Logs.err (fun m -> m "exception while writing") ; Error ())
-         (Ok ()) !known_vms
-     end) >>= function
-    | Ok () -> tcp_listener db tcp tls
-    | Error () -> Lwt.return_unit
-
-let client cas host port cert priv_key db listen_ip listen_port =
-  Nocrypto_entropy_lwt.initialize () >>= fun () ->
-  let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
-  X509_lwt.authenticator auth >>= fun authenticator ->
-  Lwt.catch (fun () ->
-    (* start TCP listening socket *)
-    let tcp = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in
-    Lwt_unix.(setsockopt tcp SO_REUSEADDR true) ;
-    let addr = Lwt_unix.ADDR_INET (Ipaddr_unix.V4.to_inet_addr listen_ip, listen_port) in
-    Lwt_unix.bind tcp addr >>= fun () ->
-    Lwt_unix.listen tcp 1 ;
-
-    (* setup remote connection to VMMD *)
-    Lwt_unix.gethostbyname host >>= 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.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
-    X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
-    let certificates = `Single cert in
-    let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
-    Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun tls ->
-
-    (* loop on both tcp and tls connections *)
-    Lwt.join [ tcp_listener db tcp tls ; tls_listener db tls ])
-    (fun exn ->
-       Logs.err (fun m -> m "failed to establish TLS connection: %s"
-                    (Printexc.to_string exn)) ;
-       Lwt.return_unit)
-
-let run_client _ cas cert key (host, port) db listen_ip listen_port =
-  Printexc.register_printer (function
-      | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
-      | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
-      | _ -> None) ;
-  Sys.(set_signal sigpipe Signal_ignore) ;
-  let db =
-    let open Rresult.R.Infix in
-    match db with
-    | None -> []
-    | Some db ->
-      match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
-      | Ok db -> db
-      | Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; []
-  in
-  Lwt_main.run (client cas host port cert key db listen_ip listen_port)
-
-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 cas =
-  let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
-  Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
-
-let client_cert =
-  let doc = "Use a client certificate chain" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let client_key =
-  let doc = "Use a client key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let destination =
-  Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
-         ~doc:"the destination hostname:port to connect to")
-
-let ip : Ipaddr.V4.t Arg.converter =
-  let parse s =
-    try
-      `Ok (Ipaddr.V4.of_string_exn s)
-    with
-      Not_found -> `Error "broken"
-  in
-  parse, Ipaddr.V4.pp_hum
-
-let address =
-  let doc = "Address to listen on" in
-  Arg.(value & opt ip (Ipaddr.V4.of_string_exn "127.0.0.1") & info [ "address" ] ~doc)
-
-let port =
-  let doc = "TCP port to listen on" in
-  Arg.(value & opt int 9080 & info [ "port" ] ~doc)
-
-let db =
-  let doc = "Certificate database" in
-  Arg.(value & opt (some file) None & info [ "db" ] ~doc)
-
-let cmd =
-  let doc = "VMM Prometheus connector" in
-  let man = [
-    `S "DESCRIPTION" ;
-    `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
-
-let () =
-  match Term.eval cmd
-  with `Error _ -> exit 1 | _ -> exit 0

app/vmm_provision.ml

@@ -1,20 +1,6 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-let asn_version = `AV0
-
-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 ())
-
-let l_exts =
-  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
-  ; (true, `Basic_constraints (false, None))
-  ; (true, `Ext_key_usage [`Client_auth]) ]
-
-let d_exts ?len () =
-  [ (true, (`Basic_constraints (true, len)))
-  ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
+let asn_version = `AV2
 
 let timestamps validity =
   let now = Ptime_clock.now () in
@@ -57,19 +43,6 @@ let sign ?dbname ?certname extensions issuer key csr delta =
      match nam with
      | `CN name -> Ok name
      | _ -> Error (`Msg "cannot happen")) >>= fun certname ->
-  (match dbname with
-   | None -> Ok None
-   | Some dbname ->
-     Bos.OS.File.exists dbname >>= function
-     | false -> Ok None
-     | true ->
-       Bos.OS.File.read_lines dbname >>= fun content ->
-       Vmm_core.parse_db content >>= fun db ->
-       match Vmm_core.find_name db certname with
-       | Ok serial ->
-         Logs.info (fun m -> m "reusing serial %s" (Z.to_string serial)) ;
-         Ok (Some serial)
-       | Error _ -> Ok None) >>= fun serial ->
   timestamps delta >>= fun (valid_from, valid_until) ->
   let extensions =
     match dbname with
@@ -80,11 +53,10 @@ let sign ?dbname ?certname extensions issuer key csr delta =
         let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in
         extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub
   in
-  let cert = X509.CA.sign csr ?serial ~valid_from ~valid_until ~extensions key issuer in
-  (match serial, dbname with
-   | Some _, _ -> Ok () (* already in DB! *)
-   | _, None -> Ok () (* no DB! *)
-   | None, Some dbname ->
+  let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in
+  (match dbname with
+   | None -> Ok () (* no DB! *)
+   | Some dbname ->
      append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.serial cert)) certname)) >>= fun () ->
   let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in
   Bos.OS.File.write Fpath.(v certname + "pem") (Cstruct.to_string enc)
@@ -107,11 +79,6 @@ let priv_key ?(bits = 2048) fn name =
 
 open Cmdliner
 
-let setup_log =
-  Term.(const setup_log
-        $ Fmt_cli.style_renderer ()
-        $ Logs_cli.level ())
-
 let nam =
   let doc = "Name to provision" in
   Arg.(required & pos 0 (some string) None & info [] ~doc)

app/vmm_stats_pure.ml

@@ -0,0 +1,196 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Astring
+open Rresult.R.Infix
+
+open Vmm_core
+
+external sysctl_rusage : int -> Stats.rusage = "vmmanage_sysctl_rusage"
+external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
+external sysctl_ifdata : int -> Stats.ifdata = "vmmanage_sysctl_ifdata"
+
+type vmctx
+
+external vmmapi_open : string -> vmctx = "vmmanage_vmmapi_open"
+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 = `AV2
+
+let descr = ref []
+
+type 'a t = {
+  pid_nic : ((vmctx, int) result * (int * string) list) IM.t ;
+  vmid_pid : int Vmm_trie.t ;
+  name_sockets : 'a Vmm_trie.t ;
+}
+
+let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps
+
+let empty () =
+  { pid_nic = IM.empty ; vmid_pid = Vmm_trie.empty ; name_sockets = Vmm_trie.empty }
+
+let remove_entry t name =
+  let name_sockets = Vmm_trie.remove name t.name_sockets in
+  { t with name_sockets }
+
+let rec wrap f arg =
+  try Some (f arg) with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> wrap f arg
+  | e ->
+    Logs.err (fun m -> m "exception %s" (Printexc.to_string e)) ;
+    None
+
+let fill_descr ctx =
+  match !descr with
+  | [] ->
+    begin match wrap vmmapi_statnames ctx with
+      | None ->
+        Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ;
+        ()
+      | Some d ->
+        Logs.debug (fun m -> m "descr are %a" pp_strings d) ;
+        descr := d
+    end
+  | ds -> Logs.debug (fun m -> m "%d descr are already present" (List.length ds))
+
+let open_vmmapi ?(retries = 4) pid =
+  let name = "solo5-" ^ string_of_int pid in
+  if retries = 0 then begin
+    Logs.debug (fun m -> m "(ignored 0) vmmapi_open failed for %d" pid) ;
+    Error 0
+  end else
+    match wrap vmmapi_open name with
+    | None ->
+      let left = max 0 (pred retries) in
+      Logs.warn (fun m -> m "(ignored, %d attempts left) vmmapi_open failed for %d" left pid) ;
+      Error left
+    | Some vmctx ->
+      Logs.info (fun m -> m "vmmapi_open succeeded for %d" pid) ;
+      fill_descr vmctx ;
+      Ok vmctx
+
+let try_open_vmmapi pid_nic =
+  IM.fold (fun pid (vmctx, nics) fresh ->
+      let vmctx =
+        match vmctx with
+        | Ok vmctx -> Ok vmctx
+        | Error retries -> open_vmmapi ~retries pid
+      in
+      IM.add pid (vmctx, nics) fresh)
+    pid_nic IM.empty
+
+let gather pid vmctx nics =
+  wrap sysctl_rusage pid,
+  (match vmctx with
+   | Error _ -> None
+   | Ok 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 -> data::ifd)
+    [] nics
+
+let tick t =
+  let pid_nic = try_open_vmmapi t.pid_nic in
+  let t' = { t with pid_nic } in
+  let outs =
+    List.fold_left (fun out (vmid, pid) ->
+        let listeners = Vmm_trie.collect vmid t'.name_sockets in
+        match listeners with
+        | [] -> Logs.warn (fun m -> m "nobody is listening") ; out
+        | xs -> match IM.find_opt pid t.pid_nic with
+          | None -> Logs.warn (fun m -> m "couldn't find nics of %d" pid) ; out
+          | Some (vmctx, nics) ->
+            let ru, vmm, ifd = gather pid vmctx nics in
+            match ru with
+            | None -> Logs.err (fun m -> m "failed to get rusage for %d" pid) ; out
+            | Some ru' ->
+              let stats =
+                let vmm' = match vmm with None -> None | Some xs -> Some (List.combine !descr xs) in
+                ru', vmm', ifd
+              in
+              List.fold_left (fun out (id, socket) ->
+                  match Vmm_core.drop_super ~super:id ~sub:vmid with
+                  | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out
+                  | Some real_id ->
+                    let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = real_id } in
+                    ((socket, vmid, (header, `Data (`Stats_data stats))) :: out))
+                out xs)
+          [] (Vmm_trie.all t'.vmid_pid)
+  in
+  (t', outs)
+
+let add_pid t vmid pid nics =
+  match wrap sysctl_ifcount () with
+  | None ->
+    Logs.err (fun m -> m "sysctl ifcount failed for %d %a" pid pp_strings nics) ;
+    Error (`Msg "sysctl ifcount failed")
+  | Some max_nic ->
+    let rec go cnt acc id =
+      if id > 0 && cnt > 0 then
+        match wrap sysctl_ifdata id with
+        | Some ifd when List.mem ifd.Vmm_core.Stats.name nics ->
+          go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id)
+        | _ -> go cnt acc (pred id)
+      else
+        List.rev acc
+    in
+    Ok (go (List.length nics) [] max_nic) >>= fun nic_ids ->
+    let vmctx = open_vmmapi pid in
+    Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics
+                  (match vmctx with Error _ -> false | Ok _ -> true)) ;
+    let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic
+    and vmid_pid, ret = Vmm_trie.insert vmid pid t.vmid_pid
+    in
+    assert (ret = None) ;
+    Ok { t with pid_nic ; vmid_pid }
+
+let remove_vmid t vmid =
+  Logs.info (fun m -> m "removing vmid %a" Vmm_core.pp_id vmid) ;
+  match Vmm_trie.find vmid t.vmid_pid with
+  | None -> Logs.warn (fun m -> m "no pid found for %a" Vmm_core.pp_id vmid) ; t
+  | Some pid ->
+    Logs.info (fun m -> m "removing pid %d" pid) ;
+    (try
+       match IM.find pid t.pid_nic with
+       | Ok vmctx, _ -> ignore (wrap vmmapi_close vmctx)
+       | Error _, _ -> ()
+     with
+       _ -> ()) ;
+    let pid_nic = IM.remove pid t.pid_nic
+    and vmid_pid = Vmm_trie.remove vmid t.vmid_pid
+    in
+    { t with pid_nic ; vmid_pid }
+
+let remove_vmids t vmids =
+  List.fold_left remove_vmid t vmids
+
+let handle t socket (header, wire) =
+  if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then begin
+    Logs.err (fun m -> m "invalid version %a (mine is %a)"
+                 Vmm_commands.pp_version header.Vmm_commands.version
+                 Vmm_commands.pp_version my_version) ;
+    Error (`Msg "cannot handle version")
+  end else
+    match wire with
+    | `Command (`Stats_cmd cmd) ->
+      begin
+        let id = header.Vmm_commands.id in
+        match cmd with
+        | `Stats_add (pid, taps) ->
+          add_pid t id pid taps >>= fun t ->
+          Ok (t, `Add id, "added")
+        | `Stats_remove ->
+          let t = remove_vmid t id in
+          Ok (t, `Remove id, "removed")
+        | `Stats_subscribe ->
+          let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in
+          Ok ({ t with name_sockets }, `Close close, "subscribed")
+      end
+    | _ ->
+      Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (header, wire)) ;
+      Error (`Msg "unexpected command")

app/vmmc_bistro.ml

@@ -0,0 +1,256 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+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 connect socket_path =
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
+  c
+
+let read fd =
+  (* now we busy read and process output *)
+  let rec loop () =
+    process fd >>= function
+    | Error e -> Lwt.return (Error e)
+    | Ok () -> loop ()
+  in
+  loop ()
+
+let key_ids pub issuer =
+  let auth = (Some (X509.key_id issuer), [], None) in
+  [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
+
+let timestamps validity =
+  let now = Ptime_clock.now () in
+  match Ptime.add_span now (Ptime.Span.of_int_s validity) with
+  | None -> invalid_arg "span too big - reached end of ptime"
+  | Some exp -> (now, exp)
+
+let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
+  Vmm_lwt.read_from_file cert >>= fun cert_cs ->
+  let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in
+  Vmm_lwt.read_from_file key >>= fun key_cs ->
+  let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
+  let tmpkey = Nocrypto.Rsa.generate 4096 in
+  let name = Vmm_core.string_of_id id in
+  let extensions =
+    [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+    ; (true, `Basic_constraints (false, None))
+    ; (true, `Ext_key_usage [`Client_auth]) ;
+      (false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in
+  let csr =
+    let name = [ `CN name ] in
+    X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey)
+  in
+  let mycert =
+    let valid_from, valid_until = timestamps 300 in
+    let extensions =
+      let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in
+      extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub)
+    in
+    let issuer = X509.subject cert in
+    X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer
+  in
+  let certificates = `Single ([ mycert ; cert ], tmpkey) in
+  X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator ->
+  Lwt_unix.gethostbyname host >>= 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.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
+  let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
+  Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
+  read t
+
+let jump endp cert key ca name cmd =
+  match
+    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)
+
+let info_policy _ endp cert key ca name =
+  jump endp cert key ca name (`Policy_cmd `Policy_info)
+
+let remove_policy _ endp cert key ca name =
+  jump endp cert key ca name (`Policy_cmd `Policy_remove)
+
+let add_policy _ endp cert key ca name vms memory cpus block bridges =
+  let p = Vmm_cli.policy vms memory cpus block bridges in
+  jump endp cert key ca name (`Policy_cmd (`Policy_add p))
+
+let destroy _ endp cert key ca name =
+  jump endp cert key ca name (`Vm_cmd `Vm_destroy)
+
+let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network compression =
+  match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
+  | Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd)
+  | Error (`Msg msg) -> `Error (false, msg)
+
+let console _ endp cert key ca name since =
+  jump endp cert key ca name (`Console_cmd (`Console_subscribe since))
+
+let stats _ endp cert key ca name =
+  jump endp cert key ca name (`Stats_cmd `Stats_subscribe)
+
+let event_log _ endp cert key ca name since =
+  jump endp cert key ca name (`Log_cmd (`Log_subscribe since))
+
+let help _ _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+open Cmdliner
+open Vmm_cli
+
+let server_ca =
+  let doc = "The certificate authority used to verify the remote server." in
+  Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc)
+
+let ca_cert =
+  let doc = "The certificate authority used to issue the certificate" in
+  Arg.(value & opt string "ca.pem" & info [ "ca" ] ~doc)
+
+let ca_key =
+  let doc = "The private key of the signing certificate authority" in
+  Arg.(value & opt string "ca.key" & info [ "ca-key" ] ~doc)
+
+let destination =
+  Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination"
+         ~doc:"the destination hostname:port to connect to")
+
+let image =
+  let doc = "File of virtual machine image." in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let vm_name =
+  let doc = "Name virtual machine." in
+  Arg.(required & pos 1 (some vm_c) None & info [] ~doc)
+
+let destroy_cmd =
+  let doc = "destroys a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroy a virtual machine."]
+  in
+  Term.(ret (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)),
+  Term.info "destroy" ~doc ~man
+
+let remove_policy_cmd =
+  let doc = "removes a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Removes a policy."]
+  in
+  Term.(ret (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "remove_policy" ~doc ~man
+
+let info_cmd =
+  let doc = "information about VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about VMs."]
+  in
+  Term.(ret (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "info" ~doc ~man
+
+let policy_cmd =
+  let doc = "active policies" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about policies."]
+  in
+  Term.(ret (const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "policy" ~doc ~man
+
+let add_policy_cmd =
+  let doc = "Add a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Adds a policy."]
+  in
+  Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.info "add_policy" ~doc ~man
+
+let create_cmd =
+  let doc = "creates a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creates a virtual machine."]
+  in
+  Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)),
+  Term.info "create" ~doc ~man
+
+let console_cmd =
+  let doc = "console of a VM" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows console output of a VM."]
+  in
+  Term.(ret (const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since)),
+  Term.info "console" ~doc ~man
+
+let stats_cmd =
+  let doc = "statistics of VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows statistics of VMs."]
+  in
+  Term.(ret (const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "stats" ~doc ~man
+
+let log_cmd =
+  let doc = "Event log" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows event log of VM."]
+  in
+  Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)),
+  Term.info "log" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmc" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about conex commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM client and go to bistro" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) executes the provided subcommand on a remote albatross" ]
+  in
+  Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

app/vmmc_local.ml

@@ -0,0 +1,215 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+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
+
+let connect socket_path =
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
+  c
+
+let read fd =
+  (* now we busy read and process output *)
+  let rec loop () =
+    process fd >>= function
+    | Error e -> Lwt.return (Error e)
+    | Ok () -> loop ()
+  in
+  loop ()
+
+let handle opt_socket id (cmd : Vmm_commands.t) =
+  let sock, next = Vmm_commands.endpoint cmd in
+  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"))
+  | Ok () ->
+    (match next with
+     | `Read -> read fd
+     | `End -> process fd) >>= fun res ->
+    Vmm_lwt.safe_close fd >|= fun () ->
+    res
+
+let jump opt_socket name cmd =
+  match
+    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)
+
+let info_policy _ opt_socket name =
+  jump opt_socket name (`Policy_cmd `Policy_info)
+
+let remove_policy _ opt_socket name =
+  jump opt_socket name (`Policy_cmd `Policy_remove)
+
+let add_policy _ opt_socket name vms memory cpus block bridges =
+  let p = Vmm_cli.policy vms memory cpus block bridges in
+  jump opt_socket name (`Policy_cmd (`Policy_add p))
+
+let destroy _ opt_socket name =
+  jump opt_socket name (`Vm_cmd `Vm_destroy)
+
+let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression =
+  match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
+  | Ok cmd -> jump opt_socket name (`Vm_cmd cmd)
+  | Error (`Msg msg) -> `Error (false, msg)
+
+let console _ opt_socket name since =
+  jump opt_socket name (`Console_cmd (`Console_subscribe since))
+
+let stats _ opt_socket name =
+  jump opt_socket name (`Stats_cmd `Stats_subscribe)
+
+let event_log _ opt_socket name since =
+  jump opt_socket name (`Log_cmd (`Log_subscribe since))
+
+let help _ _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+open Cmdliner
+open Vmm_cli
+
+let socket =
+  let doc = "Socket to connect to" in
+  Arg.(value & opt (some string) None & info [ "socket" ] ~doc)
+
+let image =
+  let doc = "File of virtual machine image." in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let vm_name =
+  let doc = "Name virtual machine." in
+  Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
+
+let destroy_cmd =
+  let doc = "destroys a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroy a virtual machine."]
+  in
+  Term.(ret (const destroy $ setup_log $ socket $ vm_name)),
+  Term.info "destroy" ~doc ~man
+
+let remove_policy_cmd =
+  let doc = "removes a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Removes a policy."]
+  in
+  Term.(ret (const remove_policy $ setup_log $ socket $ opt_vm_name)),
+  Term.info "remove_policy" ~doc ~man
+
+let info_cmd =
+  let doc = "information about VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about VMs."]
+  in
+  Term.(ret (const info_ $ setup_log $ socket $ opt_vm_name)),
+  Term.info "info" ~doc ~man
+
+let policy_cmd =
+  let doc = "active policies" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about policies."]
+  in
+  Term.(ret (const info_policy $ setup_log $ socket $ opt_vm_name)),
+  Term.info "policy" ~doc ~man
+
+let add_policy_cmd =
+  let doc = "Add a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Adds a policy."]
+  in
+  Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.info "add_policy" ~doc ~man
+
+let create_cmd =
+  let doc = "creates a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creates a virtual machine."]
+  in
+  Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)),
+  Term.info "create" ~doc ~man
+
+let console_cmd =
+  let doc = "console of a VM" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows console output of a VM."]
+  in
+  Term.(ret (const console $ setup_log $ socket $ vm_name $ since)),
+  Term.info "console" ~doc ~man
+
+let stats_cmd =
+  let doc = "statistics of VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows statistics of VMs."]
+  in
+  Term.(ret (const stats $ setup_log $ socket $ opt_vm_name)),
+  Term.info "stats" ~doc ~man
+
+let log_cmd =
+  let doc = "Event log" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows event log of VM."]
+  in
+  Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)),
+  Term.info "log" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmc" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about albatross local client commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM local client" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) connects to vmmd via a local socket" ]
+  in
+  Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

app/vmmc_remote.ml

@@ -0,0 +1,75 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+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
+  | Ok wire ->
+    Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ;
+    read_tls_write_cons t
+
+let client cas host port cert priv_key =
+  Nocrypto_entropy_lwt.initialize () >>= fun () ->
+  let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
+  X509_lwt.authenticator auth >>= fun authenticator ->
+  Lwt.catch (fun () ->
+    (* TODO TLS certificate verification and gethostbyname:
+       - allow IP address and hostname
+       - if IP is specified, use it (and no TLS name verification - or SubjAltName with IP?)
+       - if hostname is specified
+         - no ip: gethostbyname
+         - ip: connecto to ip and verify hostname *)
+    Lwt_unix.gethostbyname host >>= 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.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
+    X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
+    let certificates = `Single cert in
+    let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
+    Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
+    read_tls_write_cons t)
+    (fun exn ->
+       Logs.err (fun m -> m "failed to establish TLS connection: %s"
+                    (Printexc.to_string exn)) ;
+       Lwt.return_unit)
+
+let run_client _ cas cert key (host, port) =
+  Printexc.register_printer (function
+      | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
+      | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
+      | _ -> None) ;
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run (client cas host port cert key)
+
+open Cmdliner
+open Vmm_cli
+
+let cas =
+  let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
+  Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
+
+let client_cert =
+  let doc = "Use a client certificate chain" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let client_key =
+  let doc = "Use a client key" in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let destination =
+  Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
+         ~doc:"the destination hostname:port to connect to")
+
+let cmd =
+  let doc = "VMM remote TLS client" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) connects to a server and initiates a TLS handshake" ]
+  in
+  Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
+  Term.info "vmmc_remote" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let () =
+  match Term.eval cmd
+  with `Error _ -> exit 1 | _ -> exit 0

app/vmmd.ml

@@ -1,5 +1,7 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
+open Vmm_cli
+
 type stats = {
   start : Ptime.t ;
   vm_created : int ;
@@ -16,296 +18,188 @@ let pp_stats ppf s =
 
 open Lwt.Infix
 
-let write_raw s data =
-  Vmm_lwt.write_raw s data >|= fun _ -> ()
+let version = `AV2
 
-let write_tls state t data =
-  Vmm_tls.write_tls (fst t) data >>= function
-  | Ok () -> Lwt.return_unit
-  | Error `Exception ->
-    let state', out = Vmm_engine.handle_disconnect !state t in
-    state := state' ;
-    Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () ->
-    Tls_lwt.Unix.close (fst t)
+let state = ref (Vmm_vmmd.init version)
 
-let to_ipaddr (_, sa) = match sa with
-  | Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address"
-  | Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port
-
-let pp_sockaddr ppf (_, sa) = match sa with
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
-                                         (Unix.string_of_inet_addr addr) port
-
-let process state xs =
-  Lwt_list.iter_s (function
-      | `Raw (s, str) -> write_raw s str
-      | `Tls (s, str) -> write_tls state s str)
-    xs
-
-let handle ca state t =
-  Logs.debug (fun m -> m "connection from %a" pp_sockaddr t) ;
-  let authenticator =
-    let time = Ptime_clock.now () in
-    X509.Authenticator.chain_of_trust ~time ~crls:!state.Vmm_engine.crls [ca]
-  in
-  Lwt.catch
-    (fun () -> Tls_lwt.Unix.reneg ~authenticator (fst t))
-    (fun e ->
-       (match e with
-        | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
-        | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
-        | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
-       Tls_lwt.Unix.close (fst t) >>= fun () ->
-       Lwt.fail e) >>= fun () ->
-  (match Tls_lwt.Unix.epoch (fst t) with
-   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
-   | `Error ->
-     Tls_lwt.Unix.close (fst t) >>= fun () ->
-     Lwt.fail_with "error while getting epoch") >>= fun chain ->
-  match Vmm_engine.handle_initial !state t (to_ipaddr t) chain ca with
-  | Ok (state', outs, next) ->
-    state := state' ;
-    process state outs >>= fun () ->
-    begin match next with
-      | `Create (task, next) ->
-        (match task with
-         | None -> Lwt.return_unit
-         | Some (kill, wait) -> kill () ; wait) >>= fun () ->
+let create process cont =
   let await, wakeme = Lwt.wait () in
-        begin match next !state await with
-          | Ok (state', outs, cont) ->
-            state := state' ;
-            process state outs >>= fun () ->
-            begin match cont !state t with
-              | Ok (state', outs, vm) ->
-                state := state' ;
+  match cont !state await with
+  | Error (`Msg msg) ->
+    Logs.err (fun m -> m "create continuation failed %s" msg) ;
+    Lwt.return_unit
+  | Ok (state'', out, name, vm) ->
+    state := state'' ;
     s := { !s with vm_created = succ !s.vm_created } ;
     Lwt.async (fun () ->
         Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
-                    let state', outs = Vmm_engine.handle_shutdown !state vm r in
+        let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in
         s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
         state := state' ;
-                    process state outs >|= fun () ->
-                    Lwt.wakeup wakeme ()) ;
-                process state outs >>= fun () ->
-                begin 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 create %s" e) ;
-                let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
-                process state [ `Tls (t, err) ]
-            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
-            process state [ `Tls (t, err) ]
-        end >>= fun () ->
-        Tls_lwt.Unix.close (fst t)
-      | `Loop (prefix, perms) ->
-        let rec loop () =
-          Vmm_tls.read_tls (fst t) >>= function
+        (process out' >|= function
           | Error (`Msg msg) ->
-            Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ;
-            loop ()
-          | Error _ ->
-            Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ;
-            let state', cons = Vmm_engine.handle_disconnect !state t in
+            Logs.err (fun m -> m "error %s on handling shutdown" msg)
+          | Ok () -> ()) >|= fun () ->
+        Lwt.wakeup wakeme ()) ;
+    (process out >|= function
+      | Error (`Msg msg) -> Logs.err (fun m -> m "error %s while setting up stats and logging" msg)
+      | Ok () -> ()) >>= fun () ->
+    let state', out = Vmm_vmmd.setup_stats !state name vm in
     state := state' ;
-            Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () ->
-            Tls_lwt.Unix.close (fst t)
-          | Ok (hdr, buf) ->
-            let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in
-            state := state' ;
-            process state out >>= fun () ->
-            loop ()
+    process [ out ] >|= function
+    | Error (`Msg msg) -> Logs.err (fun m -> m "error %s sending information to stats" msg)
+    | Ok () -> ()
+
+let handle out fd addr =
+  Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
+  (* now we need to read a packet and handle it
+    (1)
+     (a) easy for info (look up name/prefix in resources)
+     (b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup)
+         logs "destroy issued"
+     (c) create initiates the vm startup procedure:
+         write image file, create fifo, create tap(s), send fifo to console
+         -- Lwt effects happen (console) --
+         executes solo5-hvt + waiter, send stats pid and taps, inserts await into state, logs "created vm"
+         -- Lwt effects happen (stats, logs, wait_and_clear) --
+    (2) goto (1)
+  *)
+  let process wires =
+    Lwt_list.fold_left_s (fun r data ->
+        match r, data with
+        | Ok (), (#Vmm_vmmd.service_out as o) -> out o
+        | Ok (), `Data wire ->
+          (* rather: terminate connection *)
+          Vmm_lwt.write_wire fd wire >|= fun _ ->
+          Ok ()
+        | Error e, _ -> Lwt.return (Error e))
+      (Ok ()) wires
   in
-        loop ()
-      | `Close socks ->
-        Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ;
-        Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () ->
-        Tls_lwt.Unix.close (fst t)
-    end
-  | Error (`Msg e) ->
-    Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ;
-    let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
-    process state [`Tls (t, err)] >>= fun () ->
-    Tls_lwt.Unix.close (fst t)
+  Logs.debug (fun m -> m "now reading") ;
+  (Vmm_lwt.read_wire fd >>= function
+    | Error _ ->
+      Logs.err (fun m -> m "error while reading") ;
+      Lwt.return_unit
+    | Ok wire ->
+      Logs.debug (fun m -> m "read sth") ;
+      let state', data, next = Vmm_vmmd.handle_command !state wire in
+      state := state' ;
+      process data >>= function
+      | Error (`Msg msg) -> Logs.err (fun m -> m "received error %s" msg) ; Lwt.return_unit
+      | Ok () -> match next with
+        | `End -> Lwt.return_unit
+        | `Wait (task, out) ->
+          task >>= fun () ->
+          process [ out ] >|= fun _ ->
+          ()
+      | `Wait_and_create (task, next) ->
+        task >>= fun () ->
+        let state', data, n = next !state in
+        state := state' ;
+        process data >>= fun _ ->
+        (match n with
+         | `End -> Lwt.return_unit
+         | `Create cont -> create process cont)
+      | `Create cont ->
+        create process cont
+        (* data contained a write to console, we need to wait for its reply first *)
+  ) >>= fun () ->
+  Vmm_lwt.safe_close fd
 
-let server_socket port =
-  let open Lwt_unix in
-  let s = socket PF_INET SOCK_STREAM 0 in
-  set_close_on_exec s ;
-  setsockopt s SO_REUSEADDR true ;
-  bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
-  listen s 10 ;
-  Lwt.return s
-
-let init_sock dir name =
+let init_sock sock =
+  let name = Vmm_core.socket_path sock in
   let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
   Lwt_unix.set_close_on_exec c ;
-  let addr = Fpath.(dir / name + "sock") in
   Lwt.catch (fun () ->
-      Lwt_unix.(connect c (ADDR_UNIX (Fpath.to_string addr))) >|= fun () -> Some c)
+      Lwt_unix.(connect c (ADDR_UNIX name)) >|= fun () -> Some c)
     (fun e ->
-       Logs.warn (fun m -> m "error %s connecting to socket %a"
-                     (Printexc.to_string e) Fpath.pp addr) ;
+       Logs.warn (fun m -> m "error %s connecting to socket %s"
+                     (Printexc.to_string e) name) ;
        (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () ->
        None)
 
-let rec read_log state s =
-  Vmm_lwt.read_exactly s >>= function
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "reading log error %s" msg) ;
-    read_log state s
-  | Error _ ->
-    Logs.err (fun m -> m "exception while reading log") ;
-    invalid_arg "log socket communication issue"
-  | Ok (hdr, data) ->
-    let state', outs = Vmm_engine.handle_log !state hdr data in
-    state := state' ;
-    process state outs >>= fun () ->
-    read_log state s
+let create_mbox sock =
+  init_sock sock >|= function
+  | None -> None
+  | Some fd ->
+    let mvar = Lwt_mvar.create_empty () in
+    (* could be more elaborate:
+       if <log> fails, we can reconnect and spit our more log messages to the new socket
+       if <console> fails, all running VMs terminate, so we can terminate as well ;)
+       if <stat> fails, we'd need to retransmit all VM info to stat (or stat has to ask at connect) *)
+    let rec loop () =
+      Lwt_mvar.take mvar >>= fun data ->
+      Vmm_lwt.write_wire fd data >>= function
+      | Ok () -> loop ()
+      | Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ;
+    in
+    Lwt.async loop ;
+    Some (mvar, fd)
 
-let rec read_cons state s =
-  Vmm_lwt.read_exactly s >>= function
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "reading console error %s" msg) ;
-    read_cons state s
-  | Error _ ->
-    Logs.err (fun m -> m "exception while reading console socket") ;
-    invalid_arg "console socket communication issue"
-  | Ok (hdr, data) ->
-    let state', outs = Vmm_engine.handle_cons !state hdr data in
-    state := state' ;
-    process state outs >>= fun () ->
-    read_cons state s
-
-let rec read_stats state s =
-  Vmm_lwt.read_exactly s >>= function
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "reading stats error %s" msg) ;
-    read_stats state s
-  | Error _ ->
-    Logs.err (fun m -> m "exception while reading stats") ;
-    Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
-    invalid_arg "stat socket communication issue"
-  | Ok (hdr, data) ->
-    let state', outs = Vmm_engine.handle_stat !state hdr data in
-    state := state' ;
-    process state outs >>= fun () ->
-    read_stats state s
-
-let cmp_s (_, a) (_, b) =
-  let open Lwt_unix in
-  match a, b with
-  | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0
-  | ADDR_INET (addr, port), ADDR_INET (addr', port') ->
-    port = port' &&
-    String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0
-  | _ -> false
+let server_socket sock =
+  let name = Vmm_core.socket_path sock in
+  (Lwt_unix.file_exists name >>= function
+    | true -> Lwt_unix.unlink name
+    | false -> Lwt.return_unit) >>= fun () ->
+  let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec s ;
+  Lwt_unix.(bind s (ADDR_UNIX name)) >|= fun () ->
+  Lwt_unix.listen s 1 ;
+  s
 
 let rec stats_loop () =
   Logs.info (fun m -> m "%a" pp_stats !s) ;
   Lwt_unix.sleep 600. >>= fun () ->
   stats_loop ()
 
-let jump _ cacert cert priv_key port =
+let jump _ =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Lwt_main.run
-    (Nocrypto_entropy_lwt.initialize () >>= fun () ->
-     (init_sock Vmm_core.tmpdir "cons" >|= function
+    (server_socket `Vmmd >>= fun ss ->
+     (create_mbox `Console >|= function
        | None -> invalid_arg "cannot connect to console socket"
-       | Some c -> c) >>= fun c ->
-     init_sock Vmm_core.tmpdir "stat" >>= fun s ->
-     (init_sock Vmm_core.tmpdir "log" >|= function
+       | Some c -> c) >>= fun (c, c_fd) ->
+     create_mbox `Stats >>= fun s ->
+     (create_mbox `Log >|= function
        | None -> invalid_arg "cannot connect to log socket"
-       | Some l -> l) >>= fun l ->
-     server_socket port >>= fun socket ->
-     X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
-     X509_lwt.certs_of_pem cacert >>= (function
-         | [ ca ] -> Lwt.return ca
-         | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
-     let config =
-       Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
-              ~reneg:true ~certificates:(`Single cert) ())
+       | Some l -> l) >>= fun (l, l_fd) ->
+     let write_reply (header, cmd) mvar fd =
+       Lwt_mvar.put mvar (header, cmd) >>= fun () ->
+       Vmm_lwt.read_wire fd >|= function
+       | Ok (header', reply) ->
+         if not Vmm_commands.(version_eq header.version header'.version) then
+           Error (`Msg "wrong version in reply")
+         else if not Vmm_commands.(Int64.equal header.sequence header'.sequence) then
+           Error (`Msg "wrong id in reply")
+         else begin match reply with
+           | `Success _ -> Ok ()
+           | `Failure msg -> Error (`Msg msg)
+           | _ -> Error (`Msg "unexpected data")
+         end
+       | Error _ -> Error (`Msg "error in read")
+     in
+     let out = function
+       | `Stat wire ->
+         begin match s with
+           | None -> Lwt.return (Ok ())
+           | Some (s, s_fd) -> write_reply wire s s_fd
+         end
+       | `Log wire -> write_reply wire l l_fd
+       | `Cons wire -> write_reply wire c c_fd
      in
-     (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
-     Lwt.async (fun () -> read_cons state c) ;
-     (match s with
-      | None -> ()
-      | Some s -> Lwt.async (fun () -> read_stats state s)) ;
-     Lwt.async (fun () -> read_log state l) ;
      Lwt.async stats_loop ;
      let rec loop () =
-       Lwt.catch (fun () ->
-           Lwt_unix.accept socket >>= fun (fd, addr) ->
+       Lwt_unix.accept ss >>= fun (fd, addr) ->
        Lwt_unix.set_close_on_exec fd ;
-           Lwt.catch
-             (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
-             (fun exn ->
-                Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
-                Lwt.fail exn) >>= fun t ->
-           Lwt.async (fun () ->
-               Lwt.catch
-                 (fun () -> handle ca state t)
-                 (fun e ->
-                    Logs.err (fun m -> m "error while handle() %s"
-                                 (Printexc.to_string e)) ;
-                    Lwt.return_unit)) ;
-           loop ())
-         (function
-           | Unix.Unix_error (e, f, _) ->
-             Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
+       Lwt.async (fun () -> handle out fd addr) ;
        loop ()
-           | Tls_lwt.Tls_failure a ->
-             Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
-             loop ()
-           | exn ->
-             Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
-             loop ())
      in
      loop ())
 
-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 cacert =
-  let doc = "CA certificate" in
-  Arg.(required & pos 0 (some file) None & info [] ~doc)
-
-let cert =
-  let doc = "Certificate" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let key =
-  let doc = "Private key" in
-  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 $ cacert $ cert $ key $ port)),
+  Term.(ret (const jump $ setup_log)),
   Term.info "vmmd" ~version:"%%VERSION_NUM%%"
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmd_console.ml

@@ -0,0 +1,185 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(* the process responsible for buffering console IO *)
+
+(* communication channel is a single unix domain socket. The following commands
+   can be issued:
+    - Add name (by vmmd) --> creates a new console slurper for name,
+       and starts a read_console task
+    - Attach name --> attaches console of name: send existing stuff to client,
+       and record the requesting socket to receive further messages. A potential
+       earlier subscriber to the same console is closed. *)
+
+open Lwt.Infix
+
+open Astring
+
+let my_version = `AV2
+
+let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
+
+let active = ref String.Map.empty
+
+let read_console name ring channel () =
+  let id = Vmm_core.id_of_string name in
+  Lwt.catch (fun () ->
+      let rec loop () =
+        Lwt_io.read_line channel >>= fun line ->
+        Logs.debug (fun m -> m "read %s" line) ;
+        let t = Ptime_clock.now () in
+        Vmm_ring.write ring (t, line) ;
+        (match String.Map.find name !active with
+         | None -> Lwt.return_unit
+         | Some fd ->
+           let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
+           Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
+           | Error _ ->
+             Vmm_lwt.safe_close fd >|= fun () ->
+             active := String.Map.remove name !active
+           | Ok () -> Lwt.return_unit) >>=
+        loop
+      in
+      loop ())
+    (fun e ->
+       begin match e with
+         | Unix.Unix_error (e, f, _) ->
+           Logs.err (fun m -> m "%s error in %s: %a" name f pp_unix_error e)
+         | End_of_file ->
+           Logs.debug (fun m -> m "%s end of file while reading" name)
+         | exn ->
+           Logs.err (fun m -> m "%s error while reading %s" name (Printexc.to_string exn))
+       end ;
+       Lwt_io.close channel)
+
+let open_fifo name =
+  let fifo = Fpath.(Vmm_core.tmpdir / "fifo" / name) 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 ->
+      Lwt.return (Some channel))
+    (function
+      | Unix.Unix_error (e, f, _) ->
+        Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
+        Lwt.return None
+      | exn ->
+        Logs.err (fun m -> m "%a error while reading %s" Fpath.pp fifo (Printexc.to_string exn)) ;
+        Lwt.return None)
+
+let t = ref String.Map.empty
+
+let add_fifo id =
+  let name = Vmm_core.string_of_id id in
+  open_fifo name >|= function
+  | Some f ->
+    let ring = Vmm_ring.create "" () in
+    Logs.debug (fun m -> m "inserting fifo %s" name) ;
+    let map = String.Map.add name ring !t in
+    t := map ;
+    Lwt.async (read_console name ring f) ;
+    Ok ()
+  | None ->
+    Error (`Msg "opening")
+
+let subscribe s id =
+  let name = Vmm_core.string_of_id id in
+  Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.pp_id id) ;
+  match String.Map.find name !t with
+  | None ->
+    active := String.Map.add name s !active ;
+    Lwt.return (None, "waiting for VM")
+  | Some r ->
+    (match String.Map.find name !active with
+     | None -> Lwt.return_unit
+     | Some s -> Vmm_lwt.safe_close s) >|= fun () ->
+    active := String.Map.add name s !active ;
+    (Some r, "subscribed")
+
+let send_history s r id since =
+  let entries =
+    match since with
+    | None -> Vmm_ring.read r
+    | Some ts -> Vmm_ring.read_history r ts
+  in
+  Logs.debug (fun m -> m "%a found %d history" Vmm_core.pp_id id (List.length entries)) ;
+  Lwt_list.iter_s (fun (i, v) ->
+      let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
+      Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function
+      | Ok () -> Lwt.return_unit
+      | Error _ -> Vmm_lwt.safe_close s)
+    entries
+
+let handle s addr () =
+  Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ;
+  let rec loop () =
+    Vmm_lwt.read_wire s >>= function
+    | Error _ ->
+      Logs.err (fun m -> m "exception while reading") ;
+      Lwt.return_unit
+    | Ok (header, `Command (`Console_cmd cmd)) ->
+      if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then begin
+        Logs.err (fun m -> m "ignoring data with bad version") ;
+        Lwt.return_unit
+      end else begin
+        let name = header.Vmm_commands.id in
+        match cmd with
+        | `Console_add ->
+          begin
+            add_fifo name >>= fun res ->
+            let reply = match res with
+              | Ok () -> `Success `Empty
+              | Error (`Msg msg) -> `Failure msg
+            in
+            Vmm_lwt.write_wire s (header, reply) >>= function
+            | Ok () -> loop ()
+            | Error _ ->
+              Logs.err (fun m -> m "error while writing") ;
+              Lwt.return_unit
+          end
+        | `Console_subscribe ts ->
+          subscribe s name >>= fun (ring, res) ->
+          Vmm_lwt.write_wire s (header, `Success (`String res)) >>= function
+          | Error _ -> Vmm_lwt.safe_close s
+          | Ok () ->
+            (match ring with
+             | None -> Lwt.return_unit
+             | Some r -> send_history s r name ts) >>= fun () ->
+            (* now we wait for the next read and terminate*)
+            Vmm_lwt.read_wire s >|= fun _ -> ()
+      end
+    | Ok wire ->
+      Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ;
+      Lwt.return ()
+  in
+  loop () >>= fun () ->
+  Vmm_lwt.safe_close s >|= fun () ->
+  Logs.warn (fun m -> m "disconnected")
+
+let jump _ file =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    ((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 () =
+       Lwt_unix.accept s >>= fun (cs, addr) ->
+       Lwt.async (handle cs addr) ;
+       loop ()
+     in
+     loop ())
+
+open Cmdliner
+
+open Vmm_cli
+
+let socket =
+  let doc = "socket to use" in
+  Arg.(value & opt string (Vmm_core.socket_path `Console) & info [ "socket" ] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ socket)),
+  Term.info "vmmd_console" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmd_influx.ml

@@ -5,6 +5,7 @@ open Lwt.Infix
 open Astring
 
 open Vmm_core
+open Vmm_core.Stats
 
 
 (*
@@ -140,11 +141,9 @@ module P = struct
       vm ifd.name (String.concat ~sep:"," fields)
 end
 
-let my_version = `WV1
+let my_version = `AV2
 
-let command = ref 1
-
-let (req : string IM.t ref) = ref IM.empty
+let command = ref 1L
 
 let str_of_e = function
   | `Eof -> "end of file"
@@ -160,12 +159,9 @@ let safe_close s =
        Logs.err (fun m -> m "exception %s while closing" (Printexc.to_string e)) ;
        Lwt.return_unit)
 
-let rec read_sock_write_tcp closing db c ?fd addr addrtype =
+let rec read_sock_write_tcp c ?fd addr addrtype =
   match fd with
   | None ->
-    if !closing then
-      Lwt.return_unit
-    else begin
     Logs.debug (fun m -> m "new connection to TCP") ;
     let fd = Lwt_unix.socket addrtype Lwt_unix.SOCK_STREAM 0 in
     Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ;
@@ -184,88 +180,50 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype =
          safe_close fd >>= fun () ->
          Lwt_unix.sleep 5.0 >|= fun () ->
          None) >>= fun fd ->
-      read_sock_write_tcp closing db c ?fd addr addrtype
-    end
+    read_sock_write_tcp c ?fd addr addrtype
   | Some fd ->
-    if !closing then
-      safe_close fd
-    else begin
-      let open Vmm_wire in
     Logs.debug (fun m -> m "reading from unix socket") ;
-      Vmm_lwt.read_exactly c >>= function
+    Vmm_lwt.read_wire c >>= function
     | Error e ->
       Logs.err (fun m -> m "error %s while reading vmm socket (return)"
                    (str_of_e e)) ;
-        closing := true ;
-        safe_close fd
-      | Ok (hdr, data) ->
-        if not (version_eq hdr.version my_version) then begin
+      safe_close fd >>= fun () ->
+      safe_close c >|= fun () ->
+      true
+    | Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) ->
+      begin
+        if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
           Logs.err (fun m -> m "unknown wire protocol version") ;
-          closing := true ;
-          safe_close fd
+          safe_close fd >>= fun () ->
+          safe_close c >|= fun () ->
+          false
         end else
-          let name =
-            try IM.find hdr.id !req
-            with Not_found -> "not found"
-          in
-          req := IM.remove hdr.id !req ;
-          begin 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 "error %s while decoding stats %s, ignoring"
-                                msg name) ;
-                  Lwt.return (Some fd)
-                | Ok (ru, vmm, ifs) ->
+          let name = string_of_id hdr.Vmm_commands.id in
           let ru = P.encode_ru name ru in
-                  let vmm = P.encode_vmm name vmm in
+          let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in
           let taps = List.map (P.encode_if name) ifs in
-                  let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in
+          let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in
           Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
-                  Vmm_lwt.write_raw fd out >>= function
+          Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function
           | Ok () ->
             Logs.debug (fun m -> m "wrote successfully") ;
-                    Lwt.return (Some fd)
+            read_sock_write_tcp c ~fd addr addrtype
           | Error e ->
             Logs.err (fun m -> m "error %s while writing to tcp (%s)"
                          (str_of_e e) name) ;
             safe_close fd >|= fun () ->
-                    None
-              end
-            | _ when hdr.tag = fail_tag ->
-              Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ;
-              Lwt.return (Some fd)
-            | _ ->
-              Logs.err (fun m -> m "unhandled tag %d for %s" hdr.tag name) ;
-              Lwt.return (Some fd)
-          end >>= fun fd ->
-          read_sock_write_tcp closing db c ?fd addr addrtype
+            false
       end
+    | Ok wire ->
+      Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
+      Lwt.return (Some fd) >>= fun fd ->
+      read_sock_write_tcp c ?fd addr addrtype
 
-let rec query_sock closing prefix db c interval =
-  (* query c for everyone in db *)
-  if !closing then
-    Lwt.return_unit
-  else
-    Lwt_list.fold_left_s (fun r (id, name) ->
-        match r with
-        | Error e -> Lwt.return (Error e)
-        | Ok () ->
-          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 ;
-          Logs.debug (fun m -> m "%d requesting %s via socket" !command id) ;
-          Vmm_lwt.write_raw c request)
-      (Ok ()) db >>= function
-    | Error e ->
-      Logs.err (fun m -> m "error %s while writing to vmm socket" (str_of_e e)) ;
-      closing := true ;
-      Lwt.return_unit
-    | Ok () ->
-      Lwt_unix.sleep (float_of_int interval) >>= fun () ->
-      query_sock closing prefix db c interval
+let query_sock vm c =
+  let header = Vmm_commands.{ version = my_version ; sequence = !command ; id = vm } in
+  command := Int64.succ !command  ;
+  Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ;
+  Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))
 
 let rec maybe_connect stat_socket =
   let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
@@ -282,10 +240,7 @@ let rec maybe_connect stat_socket =
        Lwt_unix.sleep (float_of_int 5) >>= fun () ->
        maybe_connect stat_socket)
 
-let client stat_socket influxhost influxport db prefix interval =
-  (* start a socket connection to vmm_stats *)
-  maybe_connect stat_socket >>= fun c ->
-
+let client stat_socket influxhost influxport vm =
   (* figure out address of influx *)
   Lwt_unix.gethostbyname influxhost >>= fun host_entry ->
   let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
@@ -294,7 +249,7 @@ let client stat_socket influxhost influxport db prefix interval =
   in
 
   (* loop *)
-  (* the query task queries the stat_socket at each interval
+  (* the query task queries the stat_socket at each
      - if this fails, closing is set to true (and unit is returned)
 
      the read_sock reads the stat_socket, and forwards to a TCP socket
@@ -306,82 +261,43 @@ let client stat_socket influxhost influxport db prefix interval =
      - query_sock/read_sock_write_tcp write an read from it
      - on failure in read or write, the TCP connection is closed, and loop
        takes control: safe_close, maybe_connect, rinse, repeat *)
-  let rec loop c =
-    let closing = ref false in
-    Lwt.join [
-      query_sock closing prefix db c interval ;
-      read_sock_write_tcp closing db c addr addrtype
-    ] >>= fun () ->
-    safe_close c >>= fun () ->
+
+  let rec loop () =
+    (* start a socket connection to vmm_stats *)
     maybe_connect stat_socket >>= fun c ->
-    loop c
+    query_sock vm c >>= function
+    | Error e ->
+      Logs.err (fun m -> m "error %s while writing to stat socket" (str_of_e e)) ;
+      Lwt.return_unit
+    | Ok () ->
+      read_sock_write_tcp c addr addrtype >>= fun restart ->
+      if restart then loop () else Lwt.return_unit
   in
-  loop c
+  loop ()
 
-let run_client _ socket (influxhost, influxport) db prefix interval =
+let run_client _ socket (influxhost, influxport) vm =
   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 ())
+  Lwt_main.run (client socket influxhost influxport vm)
 
 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
+open Vmm_cli
 
 let socket =
-  let doc = "Stat socket to connect onto" in
-  let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in
-  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
+  let doc = "socket to use" in
+  Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
 
 let influx =
   Arg.(required & pos 0 (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 1 (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
+  Term.(pure run_client $ setup_log $ socket $ influx $ opt_vm_name),
+  Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man
 
 let () =
   match Term.eval cmd

app/vmmd_log.ml

@@ -0,0 +1,193 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(* the process responsible for event log *)
+
+(* communication channel is a single unix domain socket shared between vmmd and
+   vmm_log.  There are two commands from vmmd to vmm_log, history and data. *)
+
+(* internally, a ring buffer for the last N events is preserved in memory
+   each new event is directly written to disk! *)
+
+open Lwt.Infix
+
+let my_version = `AV2
+
+let broadcast prefix wire t =
+  Lwt_list.fold_left_s (fun t (id, s) ->
+      Vmm_lwt.write_wire s wire >|= function
+      | Ok () -> t
+      | Error `Exception -> Vmm_trie.remove id t)
+    t (Vmm_trie.collect prefix t)
+
+let write_complete s cs =
+  let l = Cstruct.len cs in
+  let b = Cstruct.to_bytes cs in
+  let rec w off =
+    let len = l - off in
+    Lwt_unix.write s b off len >>= fun n ->
+    if n = len then Lwt.return_unit else w (off + n)
+  in
+  w 0
+
+let read_from_file file =
+  Vmm_lwt.read_from_file file >|= fun data ->
+  let logs = Vmm_asn.logs_of_disk my_version data in
+  List.rev logs
+
+let write_to_file file =
+  let mvar = Lwt_mvar.create_empty () in
+  let rec write_loop ?(retry = true) ?log_entry ?fd () =
+    match fd with
+    | None when retry ->
+      Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
+      write_loop ~retry:false ?log_entry ~fd ()
+    | None ->
+      Logs.err (fun m -> m "retry is false, exiting") ;
+      Lwt.return_unit
+    | Some fd ->
+      (match log_entry with
+       | None -> Lwt_mvar.take mvar
+       | Some l -> Lwt.return l) >>= fun log_entry ->
+      let data = Vmm_asn.log_to_disk my_version log_entry in
+      Lwt.catch
+        (fun () -> write_complete fd data >|= fun () -> (true, None, Some fd))
+        (fun e ->
+           Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
+           Vmm_lwt.safe_close fd >|= fun () ->
+           (retry, Some log_entry, None)) >>= fun (retry, log_entry, fd) ->
+      write_loop ~retry ?log_entry ?fd ()
+  in
+  mvar, write_loop
+
+let send_history s ring id ts =
+  let elements =
+    match ts with
+    | None -> Vmm_ring.read ring
+    | Some since -> Vmm_ring.read_history ring since
+  in
+  let res =
+    List.fold_left (fun acc (ts, event) ->
+        let sub = Vmm_core.Log.name event in
+        if Vmm_core.is_sub_id ~super:id ~sub
+        then (ts, event) :: acc
+        else acc)
+      [] elements
+  in
+  (* just need a wrapper in tag = Log.Data, id = reqid *)
+  Lwt_list.fold_left_s (fun r (ts, event) ->
+      match r with
+      | Ok () ->
+        let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
+        Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
+      | Error e -> Lwt.return (Error e))
+    (Ok ()) (List.rev res)
+
+let tree = ref Vmm_trie.empty
+
+let handle_data s mvar ring hdr entry =
+  if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
+    Logs.warn (fun m -> m "unsupported version") ;
+    Lwt.return_unit
+  end else begin
+    Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ ->
+    Vmm_ring.write ring entry ;
+    Lwt_mvar.put mvar entry >>= fun () ->
+    let data' = (hdr, `Data (`Log_data entry)) in
+    broadcast hdr.Vmm_commands.id data' !tree >|= fun tree' ->
+    tree := tree'
+  end
+
+let read_data mvar ring s =
+  let rec loop () =
+    Vmm_lwt.read_wire s >>= function
+    | Error _ ->
+      Logs.err (fun m -> m "error while reading") ;
+      Lwt.return_unit
+    | Ok (hdr, `Data (`Log_data entry)) ->
+      handle_data s mvar ring hdr entry >>= fun () ->
+      loop ()
+    | Ok wire ->
+      Logs.warn (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ;
+      Lwt.return_unit
+  in
+  loop ()
+
+let handle mvar ring s addr () =
+  Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ;
+  Vmm_lwt.read_wire s >>= begin function
+    | Error _ ->
+      Logs.err (fun m -> m "error while reading") ;
+      Lwt.return_unit
+    | Ok (hdr, `Data (`Log_data entry)) ->
+      handle_data s mvar ring hdr entry >>= fun () ->
+      read_data mvar ring s
+    | Ok (hdr, `Command (`Log_cmd lc)) ->
+      if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
+        Logs.warn (fun m -> m "unsupported version") ;
+        Lwt.return_unit
+      end else begin
+        match lc with
+        | `Log_subscribe ts ->
+          let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in
+          tree := tree' ;
+          (match ret with
+           | None -> Lwt.return_unit
+           | Some s' -> Vmm_lwt.safe_close s') >>= fun () ->
+          let out = `Success `Empty in
+          Vmm_lwt.write_wire s (hdr, out) >>= function
+          | Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ;
+            Lwt.return_unit
+          | Ok () ->
+            send_history s ring hdr.Vmm_commands.id ts >>= function
+            | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit
+            | Ok () ->
+              (* command processing is finished, but we leave the socket open
+                 until read returns (either with a message we ignore or a failure from the closed connection) *)
+              Vmm_lwt.read_wire s >|= fun _ -> ()
+      end
+    | Ok wire ->
+      Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
+      Lwt.return_unit
+  end >>= fun () ->
+  Vmm_lwt.safe_close s
+
+let jump _ file sock =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    ((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 ;
+     let ring = Vmm_ring.create `Startup () in
+     read_from_file file >>= fun entries ->
+     List.iter (Vmm_ring.write ring) entries ;
+     let mvar, writer = write_to_file file in
+     let start = Ptime_clock.now (), `Startup in
+     Lwt_mvar.put mvar start >>= fun () ->
+     Vmm_ring.write ring start ;
+     let rec loop () =
+       Lwt_unix.accept s >>= fun (cs, addr) ->
+       Lwt.async (handle mvar ring cs addr) ;
+       loop ()
+     in
+     Lwt.pick [ loop () ; writer () ]) ;
+  `Ok ()
+
+open Cmdliner
+open Vmm_cli
+
+let socket =
+  let doc = "socket to use" in
+  Arg.(value & opt string (Vmm_core.socket_path `Log) & info [ "socket" ] ~doc)
+
+let file =
+  let doc = "File to write the log to" in
+  Arg.(value & opt string "/var/log/albatross" & info [ "logfile" ] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ file $ socket)),
+  Term.info "vmm_log" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmd_stats.ml

@@ -14,7 +14,9 @@
 
 open Lwt.Infix
 
-let t = ref (Vmm_stats.empty ())
+open Vmm_stats_pure
+
+let t = ref (empty ())
 
 let pp_sockaddr ppf = function
   | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
@@ -23,32 +25,52 @@ let pp_sockaddr ppf = function
 
 let handle s addr () =
   Logs.info (fun m -> m "handling stats connection %a" pp_sockaddr addr) ;
-  let rec loop acc =
-    Vmm_lwt.read_exactly s >>= function
-    | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc
-    | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc
-    | Ok (hdr, data) ->
-      Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ;
-      let t', action, out = Vmm_stats.handle !t hdr data in
-      let acc = match action with
-        | `Add pid -> pid :: acc
-        | `Remove pid -> List.filter (fun m -> m <> pid) acc
-        | `None -> acc
+  let rec loop pids =
+    Vmm_lwt.read_wire s >>= function
+    | Error _ ->
+      Logs.err (fun m -> m "exception while reading") ;
+      Lwt.return pids
+    | Ok wire ->
+      match handle !t s wire with
+      | Error (`Msg msg) ->
+        Vmm_lwt.write_wire s (fst wire, `Failure msg) >>= fun _ ->
+        Lwt.return pids
+      | Ok (t', action, out) ->
+        t := t' ;
+        let pids = match action with
+        | `Add pid -> pid :: pids
+        | `Remove pid -> List.filter (fun m -> m <> pid) pids
+        | `Close _ -> pids
         in
         t := t' ;
-      Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
-      Vmm_lwt.write_raw s out >>= function
-      | Ok () -> loop acc
-      | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc
+        Vmm_lwt.write_wire s (fst wire, `Success (`String out)) >>= function
+        | Ok () ->
+          (match action with
+           | `Close (Some s') ->
+             Vmm_lwt.safe_close s' >>= fun () ->
+             (* read the next *)
+             Vmm_lwt.read_wire s >|= fun _ -> pids
+           | _ -> loop pids)
+        | Error _ ->
+          Logs.err (fun m -> m "error while writing") ;
+          Lwt.return pids
   in
   loop [] >>= fun vmids ->
-  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
+  Vmm_lwt.safe_close s >|= fun () ->
   Logs.warn (fun m -> m "disconnect, dropping %d vms!" (List.length vmids)) ;
-  let t' = Vmm_stats.remove_vmids !t vmids in
+  let t' = remove_vmids !t vmids in
   t := t'
 
 let rec timer interval () =
-  t := Vmm_stats.tick !t ;
+  let t', outs = tick !t in
+  t := t' ;
+  Lwt_list.iter_p (fun (s, name, stat) ->
+      Vmm_lwt.write_wire s stat >>= function
+      | Ok () -> Lwt.return_unit
+      | Error `Exception ->
+        t := remove_entry !t name ;
+        Vmm_lwt.safe_close s)
+    outs >>= fun () ->
   Lwt_unix.sleep interval >>= fun () ->
   timer interval ()
 
@@ -70,29 +92,19 @@ let jump _ file interval =
      in
      loop ())
 
-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 ())
+open Vmm_cli
 
 let socket =
-  let doc = "Socket to listen on" in
-  let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in
-  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
+  let doc = "socket to use" in
+  Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
 
 let interval =
   let doc = "Interval between statistics gatherings (in seconds)" in
-  Arg.(value & opt int 10 & info [ "internval" ] ~doc)
+  Arg.(value & opt int 10 & info [ "interval" ] ~doc)
 
 let cmd =
   Term.(ret (const jump $ setup_log $ socket $ interval)),
-  Term.info "vmm_stats" ~version:"%%VERSION_NUM%%"
+  Term.info "vmmd_stats" ~version:"%%VERSION_NUM%%"
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmd_tls.ml

@@ -0,0 +1,201 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+let my_version = `AV2
+
+let command = ref 0L
+
+let pp_sockaddr ppf = function
+  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+                                         (Unix.string_of_inet_addr addr) port
+
+let connect socket_path =
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
+  c
+
+let client_auth ca tls addr =
+  Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ;
+  let authenticator =
+    let time = Ptime_clock.now () in
+    X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca]
+  in
+  Lwt.catch
+    (fun () -> Tls_lwt.Unix.reneg ~authenticator tls)
+    (fun e ->
+       (match e with
+        | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
+        | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
+        | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
+       Vmm_tls_lwt.close tls >>= fun () ->
+       Lwt.fail e) >>= fun () ->
+  (match Tls_lwt.Unix.epoch tls with
+   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
+   | `Error ->
+     Vmm_tls_lwt.close tls >>= fun () ->
+     Lwt.fail_with "error while getting epoch")
+
+let read fd tls =
+  (* now we busy read and process output *)
+  let rec loop () =
+    Vmm_lwt.read_wire fd >>= function
+    | Error _ -> Lwt.return (Error (`Msg "exception while reading"))
+    | Ok wire ->
+      Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ;
+      Vmm_tls_lwt.write_tls tls wire >>= function
+      | Ok () -> loop ()
+      | Error `Exception -> Lwt.return (Error (`Msg "exception"))
+  in
+  loop ()
+
+let process fd tls =
+  Vmm_lwt.read_wire fd >>= function
+  | Error _ -> Lwt.return (Error (`Msg "read error"))
+  | Ok wire ->
+    (* TODO check version *)
+    Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ;
+    Vmm_tls_lwt.write_tls tls wire >|= function
+    | Ok () -> Ok ()
+    | Error `Exception -> Error (`Msg "exception on write")
+
+let handle ca (tls, addr) =
+  client_auth ca tls addr >>= fun chain ->
+  match Vmm_tls.handle addr my_version chain with
+  | Error (`Msg m) ->
+    Vmm_tls_lwt.close tls >>= fun () ->
+    Lwt.fail_with m
+  | Ok (name, policies, cmd) ->
+    let sock, next = Vmm_commands.endpoint cmd in
+    connect (Vmm_core.socket_path sock) >>= fun fd ->
+    (match sock with
+     | `Vmmd ->
+       Lwt_list.fold_left_s (fun r (id, policy) ->
+           match r with
+           | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
+           | Ok () ->
+             Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.pp_id id Vmm_core.pp_policy policy) ;
+             let header = Vmm_commands.{version = my_version ; sequence = !command ; id } in
+             command := Int64.succ !command ;
+             Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function
+             | Error `Exception -> Lwt.return (Error (`Msg "failed to write policy"))
+             | Ok () ->
+               Vmm_lwt.read_wire fd >|= function
+               | Error _ -> Error (`Msg "read error")
+               | Ok (_, `Success _) -> Ok ()
+               | Ok _ ->
+                 (* TODO check version *)
+                 Error (`Msg ("expected success, received something else when adding policy")))
+         (Ok ()) policies
+     | _ -> Lwt.return (Ok ())) >>= function
+    | Error (`Msg msg) ->
+      begin
+        Logs.debug (fun m -> m "error while applying policies %s" msg) ;
+        let wire =
+          let header = Vmm_commands.{version = my_version ; sequence = 0L ; id = name } in
+          header, `Failure msg
+        in
+        Vmm_tls_lwt.write_tls tls wire >>= fun _ ->
+        Vmm_tls_lwt.close tls >>= fun () ->
+        Vmm_lwt.safe_close fd >>= fun () ->
+        Lwt.fail_with msg
+      end
+    | Ok () ->
+      let wire =
+        let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in
+        command := Int64.succ !command ;
+        (header, `Command cmd)
+      in
+      Vmm_lwt.write_wire fd wire >>= function
+      | Error `Exception ->
+        Vmm_tls_lwt.close tls >>= fun () ->
+        Vmm_lwt.safe_close fd >>= fun () ->
+        Lwt.return (Error (`Msg "couldn't write"))
+      | Ok () ->
+        (match next with
+         | `Read -> read fd tls
+         | `End -> process fd tls) >>= fun res ->
+        Vmm_tls_lwt.close tls >>= fun () ->
+        Vmm_lwt.safe_close fd >|= fun () ->
+        res
+
+let server_socket port =
+  let open Lwt_unix in
+  let s = socket PF_INET SOCK_STREAM 0 in
+  set_close_on_exec s ;
+  setsockopt s SO_REUSEADDR true ;
+  bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
+  listen s 10 ;
+  Lwt.return s
+
+let jump _ cacert cert priv_key port =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    (Nocrypto_entropy_lwt.initialize () >>= fun () ->
+     server_socket port >>= fun socket ->
+     X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
+     X509_lwt.certs_of_pem cacert >>= (function
+         | [ ca ] -> Lwt.return ca
+         | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
+     let config =
+       Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
+              ~reneg:true ~certificates:(`Single cert) ())
+     in
+     let rec loop () =
+       Lwt.catch (fun () ->
+           Lwt_unix.accept socket >>= fun (fd, addr) ->
+           Lwt_unix.set_close_on_exec fd ;
+           Lwt.catch
+             (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
+             (fun exn ->
+                Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
+                Lwt.fail exn) >>= fun t ->
+           Lwt.async (fun () ->
+               Lwt.catch
+                 (fun () -> handle ca t >|= function
+                    | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg)
+                    | Ok () -> ())
+                 (fun e ->
+                    Logs.err (fun m -> m "error while handle() %s"
+                                 (Printexc.to_string e)) ;
+                    Lwt.return_unit)) ;
+           loop ())
+         (function
+           | Unix.Unix_error (e, f, _) ->
+             Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
+             loop ()
+           | Tls_lwt.Tls_failure a ->
+             Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
+             loop ()
+           | exn ->
+             Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
+             loop ())
+     in
+     loop ())
+
+open Cmdliner
+open Vmm_cli
+
+let cacert =
+  let doc = "CA certificate" in
+  Arg.(required & pos 0 (some file) None & info [] ~doc)
+
+let cert =
+  let doc = "Certificate" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let key =
+  let doc = "Private key" in
+  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 $ cacert $ cert $ key $ port)),
+  Term.info "vmmd_tls" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmp_ca.ml

@@ -0,0 +1,166 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Rresult.R.Infix
+
+let l_exts =
+  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+  ; (true, `Basic_constraints (false, None))
+  ; (true, `Ext_key_usage [`Client_auth]) ]
+
+let d_exts ?len () =
+  [ (true, (`Basic_constraints (true, len)))
+  ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
+
+let s_exts =
+  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+  ; (true, `Basic_constraints (false, None))
+  ; (true, `Ext_key_usage [`Server_auth]) ]
+
+let albatross_extension csr =
+  let req_exts =
+    match
+      List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions)
+    with
+    | exception Not_found -> []
+    | `Extensions x -> x
+    | _ -> []
+  in
+  match
+    List.filter (function
+        | (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
+        | _ -> false)
+      req_exts
+  with
+  | [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
+  | _ -> Error (`Msg "couldn't find albatross extension in CSR")
+
+let sign dbname cacert key csr days =
+  let ri = X509.CA.info csr in
+  Logs.app (fun m -> m "signing certificate with subject %s"
+               (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
+  let issuer = X509.subject cacert in
+  (* TODO: check delegation! verify whitelisted commands!? *)
+  match albatross_extension csr with
+  | Ok (ext, v) ->
+    Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
+    (if Vmm_commands.version_eq version version then
+       Ok ()
+     else
+       Error (`Msg "unknown version in request")) >>= fun () ->
+    let exts = match cmd with
+      | `Policy_cmd (`Policy_add _) -> d_exts ()
+      | _ -> l_exts
+    in
+    Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
+    Ok (ext :: exts) >>= fun extensions ->
+    Vmm_provision.sign ~dbname extensions issuer key csr (Duration.of_day days)
+  | Error e -> Error e
+
+let sign _ db cacert cakey csrname days =
+  let days = match days with None -> 1 | Some x -> x in
+  Nocrypto_entropy_unix.initialize () ;
+  match
+    Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
+    let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
+    Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
+    let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
+    Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
+    let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
+    sign (Fpath.v db) cacert cakey csr days
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg e) -> `Error (false, e)
+
+let help _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+let generate _ name db days sname sdays =
+  let days = match days with None -> 3650 | Some x -> x in
+  Nocrypto_entropy_unix.initialize () ;
+  match
+    Vmm_provision.priv_key ~bits:4096 None name >>= fun key ->
+    let name = [ `CN name ] in
+    let csr = X509.CA.request name key in
+    Vmm_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
+    Vmm_provision.priv_key None sname >>= fun skey ->
+    let sname = [ `CN sname ] in
+    let csr = X509.CA.request sname skey in
+    Vmm_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg e) -> `Error (false, e)
+
+open Cmdliner
+open Vmm_cli
+
+let csr =
+  let doc = "signing request" in
+  Arg.(required & pos 3 (some file) None & info [] ~doc)
+
+let key =
+  let doc = "Private key" in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let days =
+  let doc = "Number of days" in
+  Arg.(value & opt (some int) None & info [ "days" ] ~doc)
+
+let db =
+  let doc = "Database" in
+  Arg.(required & pos 1 (some string) None & info [] ~doc)
+
+let sname =
+  let doc = "Server name" in
+  Arg.(value & opt string "server" & info [ "server" ] ~doc)
+
+let sday =
+  let doc = "Server validity" in
+  Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
+
+let generate_cmd =
+  let doc = "generates a certificate authority" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Generates a certificate authority."]
+  in
+  Term.(ret (const generate $ setup_log $ Vmm_provision.nam $ db $ days $ sname $ sday)),
+  Term.info "generate" ~doc ~man
+
+let sign_cmd =
+  let doc = "sign a request" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Signs the certificate signing request."]
+  in
+  Term.(ret (const sign $ setup_log $ db $ Vmm_provision.cacert $ key $ csr $ days)),
+  Term.info "sign" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmp_sign" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM " in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) executes the provided subcommand on a remote albatross" ]
+  in
+  Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmp_ca" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

app/vmmp_request.ml

@@ -0,0 +1,180 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Vmm_provision
+open Vmm_asn
+
+open Rresult.R.Infix
+
+let version = `AV2
+
+let csr priv name cmd =
+  let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (version, cmd))) ]
+  and name = [ `CN name ]
+  in
+  X509.CA.request name ~extensions:[`Extensions exts] priv
+
+let jump id cmd =
+  Nocrypto_entropy_unix.initialize () ;
+  let name = Vmm_core.string_of_id id in
+  match
+    priv_key None name >>= fun priv ->
+    let csr = csr priv name cmd in
+    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
+    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg m) -> `Error (false, m)
+
+let info_ _ name = jump name (`Vm_cmd `Vm_info)
+
+let info_policy _ name =
+  jump name (`Policy_cmd `Policy_info)
+
+let remove_policy _ name =
+  jump name (`Policy_cmd `Policy_remove)
+
+let add_policy _ name vms memory cpus block bridges =
+  let p = Vmm_cli.policy vms memory cpus block bridges in
+  jump name (`Policy_cmd (`Policy_add p))
+
+let destroy _ name =
+  jump name (`Vm_cmd `Vm_destroy)
+
+let create _ force name image cpuid requested_memory boot_params block_device network compression =
+  match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
+  | Ok cmd -> jump name (`Vm_cmd cmd)
+  | Error (`Msg msg) -> `Error (false, msg)
+
+let console _ name since =
+  jump name (`Console_cmd (`Console_subscribe since))
+
+let stats _ name =
+  jump name (`Stats_cmd `Stats_subscribe)
+
+let event_log _ name since =
+  jump name (`Log_cmd (`Log_subscribe since))
+
+let help _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+open Cmdliner
+open Vmm_cli
+
+let image =
+  let doc = "File of virtual machine image." in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let vm_name =
+  let doc = "Name virtual machine." in
+  Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
+
+let destroy_cmd =
+  let doc = "destroys a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroy a virtual machine."]
+  in
+  Term.(ret (const destroy $ setup_log $ vm_name)),
+  Term.info "destroy" ~doc ~man
+
+let remove_policy_cmd =
+  let doc = "removes a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Removes a policy."]
+  in
+  Term.(ret (const remove_policy $ setup_log $ opt_vm_name)),
+  Term.info "remove_policy" ~doc ~man
+
+let info_cmd =
+  let doc = "information about VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about VMs."]
+  in
+  Term.(ret (const info_ $ setup_log $ opt_vm_name)),
+  Term.info "info" ~doc ~man
+
+let policy_cmd =
+  let doc = "active policies" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about policies."]
+  in
+  Term.(ret (const info_policy $ setup_log $ opt_vm_name)),
+  Term.info "policy" ~doc ~man
+
+let add_policy_cmd =
+  let doc = "Add a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Adds a policy."]
+  in
+  Term.(ret (const add_policy $ setup_log $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.info "add_policy" ~doc ~man
+
+let create_cmd =
+  let doc = "creates a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creates a virtual machine."]
+  in
+  Term.(ret (const create $ setup_log $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)),
+  Term.info "create" ~doc ~man
+
+let console_cmd =
+  let doc = "console of a VM" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows console output of a VM."]
+  in
+  Term.(ret (const console $ setup_log $ vm_name $ since)),
+  Term.info "console" ~doc ~man
+
+let stats_cmd =
+  let doc = "statistics of VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows statistics of VMs."]
+  in
+  Term.(ret (const stats $ setup_log $ opt_vm_name)),
+  Term.info "stats" ~doc ~man
+
+let log_cmd =
+  let doc = "Event log" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows event log of VM."]
+  in
+  Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)),
+  Term.info "log" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmc" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about albatross local client commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM local client" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) connects to vmmd via a local socket" ]
+  in
+  Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

myocamlbuild.ml

@@ -19,8 +19,8 @@ let () =
       flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"]
         (S ([A "-cclib"; A "-lvmm_stats_stubs"]));
       flag ["link"; "ocaml"; "link_vmm_stats"]
-        (S ([A "stats/libvmm_stats_stubs.a"] @ vmm_lib));
-      dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
-      dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
+        (S ([A "app/libvmm_stats_stubs.a"] @ vmm_lib));
+      dep ["link"; "ocaml"; "use_vmm_stats"] ["app/libvmm_stats_stubs.a"];
+      dep ["link"; "ocaml"; "link_vmm_stats"] ["app/libvmm_stats_stubs.a"];
     | _ -> ()
   end

opam

@@ -1,12 +1,12 @@
-opam-version: "1.2"
+opam-version: "2.0"
 maintainer: "Hannes Mehnert <hannes@mehnert.org>"
 authors: ["Hannes Mehnert <hannes@mehnert.org>"]
-homepage: "https://github.com/hannesm/vmm"
-dev-repo: "https://github.com/hannesm/vmm.git"
-bug-reports: "https://github.com/hannesm/vmm/issues"
-available: [ ocaml-version >= "4.04.0"]
+homepage: "https://github.com/hannesm/albatross"
+dev-repo: "git+https://github.com/hannesm/albatross.git"
+bug-reports: "https://github.com/hannesm/albatross/issues"
 
 depends: [
+  "ocaml" {>= "4.05.0"}
   "ocamlfind" {build}
   "ocamlbuild" {build}
   "topkg" {build}
@@ -14,7 +14,6 @@ depends: [
   "ipaddr" {>= "2.2.0"}
   "hex"
   "cstruct"
-  "ppx_cstruct" {build & >= "3.0.0"}
   "logs"
   "rresult"
   "bos"
@@ -27,9 +26,10 @@ depends: [
   "nocrypto"
   "asn1-combinators" {>= "0.2.0"}
   "duration"
-  "decompress" {>= "0.7"}
+  "decompress" {= "0.7"}
 ]
 
 build: [
   [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
 ]
+synopsis: "Albatross - orchestrate and manage MirageOS unikernels"

packaging/MANIFEST

@@ -0,0 +1,83 @@
+name:         albatross
+version:      1.0.%%GITVER%%_1
+origin:	      local/albatross
+comment:      Albatross: Managing virtual machines
+www:	      https://github.com/hannesm/albatross
+maintainer:   Hannes Mehnert <hannes@mehnert.org>
+prefix:	      /usr/local
+licenselogic: single
+licenses:     [NONE]
+flatsize:     %%FLATSIZE%%
+categories:   [local]
+deps {
+        gmp {
+        origin = "math/gmp";
+        version = "6.1.2";
+    }
+}
+scripts : {
+    pre-install = <<EOD
+if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
+  PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
+else
+  PW=/usr/sbin/pw
+fi
+echo "===> Creating groups."
+if ! ${PW} groupshow albatross >/dev/null 2>&1; then
+  echo "Creating group 'albatross' with gid '496'."
+  ${PW} groupadd albatross -g 496
+else
+  echo "Using existing group 'albatross'."
+fi
+echo "===> Creating users"
+if ! ${PW} usershow albatross >/dev/null 2>&1; then
+  echo "Creating user 'albatross' with uid '496'."
+  ${PW} useradd albatross -u 496 -g 496  -c "albatross daemon" -d /nonexistent -s /usr/sbin/nologin
+else
+  echo "Using existing user 'albatross'."
+fi
+EOD;
+    post-install = <<EOD
+mkdir -p /var/run/albatross/util /var/run/albatross/fifo
+chown albatross:albatross /var/run/albatross/util /var/run/albatross/fifo
+chmod 2760 /var/run/albatross/fifo
+chgrp albatross /usr/local/libexec/albatross/vmmd
+chmod 2700 /usr/local/libexec/albatross/vmmd
+
+EOD;
+    post-deinstall = <<EOD
+if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
+  PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
+else
+  PW=/usr/sbin/pw
+fi
+if ${PW} usershow albatross >/dev/null 2>&1; then
+  echo "==> You should manually remove the \"albatross\" user. "
+fi
+if ${PW} groupshow albatross >/dev/null 2>&1; then
+  echo "==> You should manually remove the \"albatross\" group "
+fi
+EOD;
+
+}
+desc = <<EOD
+A set of binaries to manage, provision, and deploy virtual machine images.
+
+EOD;
+messages [
+    {
+        message = <<EOD
+===================================================================
+
+	you need to:
+
+   * modify /etc/devfs.rules to include:
+
+	add path 'vmm/solo5*' mode 0660 group albatross
+
+   * install solo5-hvt.net  solo5-hvt.none in /var/db/albatross
+
+===================================================================
+EOD;
+    }
+]

packaging/create_package.sh

@@ -0,0 +1,52 @@
+#!/bin/sh -e
+
+basedir=$(realpath "$(dirname "$0")"/..)
+#tmptmpl=$(basename "$0")
+#tmpd=$(mktemp -t "$tmptmpl")
+tmpd=$basedir/_build/stage
+manifest=$tmpd/+MANIFEST
+rootdir=$tmpd/rootdir
+
+
+trap 'rm -rf $tmpd' 0 INT EXIT
+
+mkdir -p "$rootdir"/usr/local/sbin \
+         "$rootdir"/usr/local/libexec/albatross \
+         "$rootdir"/usr/local/etc/rc.d
+
+# stage service scripts
+for f in albatross_log \
+	 albatross_stat \
+	 albatross_console \
+	 albatross_daemon \
+	 albatross_x
+do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done
+
+# stage albatross app binaries
+for f in vmmd vmmd_log vmmd_console vmmd_stats vmmd_influx vmmd_tls; do
+    install -U $basedir/_build/app/$f.native \
+	 $rootdir/usr/local/libexec/albatross/$f; done
+
+for f in vmmc_local vmmc_remote vmmc_bistro vmmp_ca vmmp_request; do
+    install -U $basedir/_build/app/$f.native \
+	$rootdir/usr/local/sbin/$f; done
+
+# create +MANIFEST
+flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |
+               awk 'BEGIN {s=0} {s+=$1} END {print s}')
+
+gitver=$(git rev-parse --short HEAD)
+
+sed -e "s:%%GITVER%%:${gitver}:" -e "s:%%FLATSIZE%%:${flatsize}:" \
+    "$basedir/packaging/MANIFEST" > "$manifest"
+
+{
+    printf '\nfiles {\n'
+    find "$rootdir" -type f -exec sha256 -r {} + |
+        awk '{print "    " $2 ": \"" $1 "\"," }'
+    find "$rootdir" -type l |
+        awk "{print \"    \"\$1 \": -,\"}"
+    printf '}\n'
+} | sed -e "s:${rootdir}::" >> "$manifest"
+
+pkg create -r "$rootdir" -M "$manifest" -o $basedir/_build/

packaging/rc.d/albatross_console

@@ -0,0 +1,39 @@
+#!/bin/sh
+
+# $FreeBSD$
+#
+# PROVIDE: albatross_console
+# REQUIRE: LOGIN
+# KEYWORD: shutdown nojail
+#
+# Define these albatross_console_* variables in one of these files
+# 	 /etc/rc.conf
+#	 /etc/rc.conf.local
+#	 /etc/rc.conf.d/albatross_console
+#	 /usr/local/etc/rc.conf.d/albatross_console
+#
+# albatross_console_flags:
+#                       Default: ""
+#
+
+. /etc/rc.subr
+
+name=albatross_console
+rcvar=${name}_enable
+desc="Albatross console service"
+load_rc_config $name
+start_cmd="albatross_console_start"
+
+: ${albatross_console_enable:="NO"}
+: ${albatross_console_flags:=""}
+: ${albatross_console_user:="albatross"}
+
+pidfile="/var/run/albatross_console.pid"
+procname="/usr/local/libexec/albatross/vmmd_console"
+
+albatross_console_start () {
+    /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \
+		     "${procname}" "${albatross_console_flags}"
+}
+
+run_rc_command "$1"

packaging/rc.d/albatross_daemon

@@ -0,0 +1,74 @@
+#!/bin/sh
+
+# $FreeBSD$
+#
+# PROVIDE: albatross_daemon
+# REQUIRE: LOGIN albatross_console albatross_log albatross_stat
+# KEYWORD: shutdown nojail
+#
+# Define these albatross_daemon_* variables in one of these files
+# 	 /etc/rc.conf
+#	 /etc/rc.conf.local
+#	 /etc/rc.conf.d/albatross_daemon
+#	 /usr/local/etc/rc.conf.d/albatross_daemon
+#
+# albatross_daemon_enable:	Set YES to enable the albatross daemon service
+# 		Default: NO
+# albatross_daemon_flags:
+# 		Default: ""
+#
+#
+
+. /etc/rc.subr
+
+name=albatross_daemon
+rcvar=${name}_enable
+desc="Albatross service"
+load_rc_config $name
+start_cmd="albatross_daemon_start"
+start_precmd="albatross_daemon_precmd"
+
+: ${albatross_daemon_enable:="NO"}
+: ${albatross_daemon_flags:=""}
+
+pidfile="/var/run/albatross_daemon.pid"
+procname="/usr/local/libexec/albatross/vmmd"
+
+#
+# force_depend script [rcvar]
+#	Force a service to start. Intended for use by services
+#	to resolve dependency issues.
+#	$1 - filename of script, in /usr/local/etc/rc.d, to run
+#	$2 - name of the script's rcvar (minus the _enable)
+#
+my_force_depend()
+{
+	local _depend _dep_rcvar
+
+	_depend="$1"
+	_dep_rcvar="${2:-$1}_enable"
+
+	[ -n "$rc_fast" ] && ! checkyesno always_force_depends &&
+	    checkyesno $_dep_rcvar && return 0
+
+	/usr/local/etc/rc.d/${_depend} forcestatus >/dev/null 2>&1 && return 0
+
+	info "${name} depends on ${_depend}, which will be forced to start."
+	if ! /usr/local/etc/rc.d/${_depend} forcestart; then
+		warn "Unable to force ${_depend}. It may already be running."
+		return 1
+	fi
+}
+
+albatross_daemon_precmd() {
+    my_force_depend albatross_console || err 1 "Cannot run albatross_console"
+    my_force_depend albatross_log || err 1 "Cannot run albatross_log"
+    my_force_depend albatross_stat || err 1 "Cannot run albatross_stat"
+}
+
+albatross_daemon_start () {
+    /usr/sbin/daemon -S -p "${pidfile}" "${procname}" \
+                     "${albatross_daemon_flags}"
+}
+
+run_rc_command "$1"

packaging/rc.d/albatross_log

@@ -0,0 +1,47 @@
+#!/bin/sh
+
+# $FreeBSD$
+#
+# PROVIDE: albatross_log
+# REQUIRE: LOGIN
+# KEYWORD: shutdown nojail
+#
+# Define these albatross_log_* variables in one of these files
+# 	 /etc/rc.conf
+#	 /etc/rc.conf.local
+#	 /etc/rc.conf.d/albatross_log
+#	 /usr/local/etc/rc.conf.d/albatross_log
+#
+# albatross_log_flags:
+#                       Default: ""
+#
+
+. /etc/rc.subr
+
+name=albatross_log
+rcvar=${name}_enable
+desc="Albatross log service"
+load_rc_config $name
+start_cmd="albatross_log_start"
+start_precmd="albatross_log_precmd"
+
+: ${albatross_log_enable:="NO"}
+: ${albatross_log_flags:=""}
+: ${albatross_log_user:="albatross"}
+
+pidfile="/var/run/albatross_log.pid"
+procname="/usr/local/libexec/albatross/vmmd_log"
+logfile="/var/log/albatross"
+
+albatross_log_precmd () {
+    [ -e "${logfile}" ] ||
+	install -g ${albatross_log_user} -o ${albatross_log_user} \
+		-- /dev/null "${logfile}";
+}
+
+albatross_log_start () {
+    /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_log_user}" \
+		     "${procname}" "${albatross_log_flags}"
+}
+
+run_rc_command "$1"

packaging/rc.d/albatross_stat

@@ -0,0 +1,39 @@
+#!/bin/sh
+
+# $FreeBSD$
+#
+# PROVIDE: albatross_stat
+# REQUIRE: LOGIN
+# KEYWORD: shutdown nojail
+#
+# Define these albatross_stat_* variables in one of these files
+# 	 /etc/rc.conf
+#	 /etc/rc.conf.local
+#	 /etc/rc.conf.d/albatross_stat
+#	 /usr/local/etc/rc.conf.d/albatross_stat
+#
+# albatross_stat_flags:
+#                       Default: ""
+#
+
+. /etc/rc.subr
+
+name=albatross_stat
+rcvar=${name}_enable
+desc="Albatross stat service"
+load_rc_config $name
+start_cmd="albatross_stat_start"
+
+: ${albatross_stat_enable:="NO"}
+: ${albatross_stat_flags:=""}
+: ${albatross_stat_user:="albatross"}
+
+pidfile="/var/run/albatross_stat.pid"
+procname="/usr/local/libexec/albatross/vmmd_stats"
+
+albatross_stat_start () {
+    /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_stat_user}" \
+		     "${procname}" "${albatross_stat_flags}"
+}
+
+run_rc_command "$1"

packaging/rc.d/albatross_x

@@ -0,0 +1,73 @@
+#!/bin/sh
+
+# $FreeBSD$
+#
+# PROVIDE: albatross_x
+# REQUIRE: LOGIN albatross_daemon
+# KEYWORDS: shutdown nojail
+#
+# Define these albatross_x_* variables in one of these files
+# 	 /etc/rc.conf
+#	 /etc/rc.conf.local
+#	 /etc/rc.conf.d/albatross_x
+#	 /usr/local/etc/rc.conf.d/albatross_x
+#
+# albatross_x_enable:	Set YES to enable the albatross vm start service
+# 		Default: NO
+# albatross_x_vms:       list of vms to manage
+# 		Default: ""
+# albatross_x_args_$VM: vm create arguments
+#
+#
+
+. /etc/rc.subr
+
+name=albatross_x
+rcvar=${name}_enable
+desc="Manage Albatross VMs"
+load_rc_config $name
+start_cmd="albatross_x_start"
+stop_cmd="albatross_x_stop"
+status_cmd="albatross_x_status"
+extra_commands="status"
+
+: ${albatross_x_enable:="NO"}
+: ${albatross_x_vms:=""}
+
+albatross_x_start () {
+    case $1 in
+	_ALL)
+	    for _vm in $albatross_x_vms; do
+		eval _create_args=\"\$albatross_x_args_${_vm}\"
+		/usr/local/sbin/vmmc_local create $_vm $_create_args
+	    done
+	    return
+	    ;;
+    esac
+    for _vm in $@; do
+	eval _create_args=\"\$albatross_x_args_${_vm}\"
+	/usr/local/sbin/vmmc_local create $_vm $_create_args
+    done
+}
+
+albatross_x_stop () {
+    case $1 in
+	ALL)
+	    for _vm in $albatross_x_vms
+	    do /usr/local/sbin/vmmc_local destroy $_vm; done
+	    return
+    esac
+    for _vm in $@
+    do /usr/local/sbin/vmmc_local destroy $_vm; done
+}
+
+albatross_x_status () {
+    for _vm in $@
+    do /usr/local/sbin/vmmc_local info $_vm; done
+}
+
+case $# in
+    1) run_rc_command $@ ${albatross_x_list:-_ALL} ;;
+    *) run_rc_command $@ ;;
+esac
+

pkg/META

@@ -1,7 +1,2 @@
 description = "VM Manager"
 version = "%%VERSION_NUM%%"
-requires = "rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration asn1-combinators lwt tls.lwt decompress"
-archive(byte) = "vmm.cma"
-archive(native) = "vmm.cmxa"
-plugin(byte) = "vmm.cma"
-plugin(native) = "vmm.cmxs"

pkg/pkg.ml

@@ -7,17 +7,14 @@ let () =
   Pkg.describe "albatross" @@ fun _ ->
   Ok [
     Pkg.bin "app/vmmd" ;
-    Pkg.bin "app/vmm_console" ;
-    Pkg.bin "app/vmm_log" ;
-    Pkg.bin "app/vmm_client" ;
-    Pkg.bin "provision/vmm_req_permissions" ;
-    Pkg.bin "provision/vmm_req_delegation" ;
-    Pkg.bin "provision/vmm_req_vm" ;
-    Pkg.bin "provision/vmm_sign" ;
-    Pkg.bin "provision/vmm_revoke" ;
-    Pkg.bin "provision/vmm_gen_ca" ;
-    Pkg.clib "stats/libvmm_stats_stubs.clib" ;
-    Pkg.bin "stats/vmm_stats_lwt" ;
-    Pkg.bin "app/vmm_prometheus_stats" ;
-    Pkg.bin "app/vmm_influxdb_stats" ;
+    Pkg.bin "app/vmmd_console" ;
+    Pkg.bin "app/vmmd_log" ;
+    Pkg.bin "app/vmmd_stats" ;
+    Pkg.bin "app/vmmd_tls" ;
+    Pkg.bin "app/vmmd_influx" ;
+    Pkg.bin "app/vmmc_local" ;
+    Pkg.bin "app/vmmc_remote" ;
+    Pkg.bin "app/vmmc_bistro" ;
+    Pkg.bin "app/vmmp_request" ;
+    Pkg.bin "app/vmmp_ca" ;
   ]

provision/vmm_gen_ca.ml

@@ -1,50 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-let s_exts =
-  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
-  ; (true, `Basic_constraints (false, None))
-  ; (true, `Ext_key_usage [`Server_auth]) ]
-
-let jump _ name db days sname sdays =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key ~bits:4096 None name >>= fun key ->
-    let name = [ `CN name ] in
-    let csr = X509.CA.request name key in
-    sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
-    priv_key None sname >>= fun skey ->
-    let sname = [ `CN sname ] in
-    let csr = X509.CA.request sname skey in
-    sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg e) -> `Error (false, e)
-
-
-open Cmdliner
-
-let days =
-  let doc = "Number of days" in
-  Arg.(value & opt int 3650 & info [ "days" ] ~doc)
-
-let db =
-  let doc = "Database" in
-  Arg.(required & pos 1 (some string) None & info [] ~doc)
-
-let sname =
-  let doc = "Server name" in
-  Arg.(value & opt string "server" & info [ "server" ] ~doc)
-
-let sday =
-  let doc = "Server validity" in
-  Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)),
-  Term.info "vmm_gen_ca" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_req_delegation.ml

@@ -1,85 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-open Vmm_asn
-
-open Rresult.R.Infix
-
-open Astring
-
-let subca_csr key name cpus mem vms block bridges =
-  let block = match block with
-    | None -> []
-    | Some x -> [ (false, `Unsupported (Oid.block, int_to_cstruct x)) ]
-  and bridge = match bridges with
-    | [] -> []
-    | xs -> [ (false, `Unsupported (Oid.bridges, bridges_to_cstruct xs)) ]
-  in
-  let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
-      (false, `Unsupported (Oid.cpuids, ints_to_cstruct cpus)) ;
-      (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
-      (false, `Unsupported (Oid.vms, int_to_cstruct vms)) ;
-    ] @ block @ bridge
-  and name = [ `CN name ]
-  in
-  X509.CA.request name ~extensions:[`Extensions exts] key
-
-let jump _ name key vms mem cpus block bridges =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key key name >>= fun key ->
-    let csr = subca_csr key name cpus mem vms block bridges in
-    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
-    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
-
-open Cmdliner
-
-let cpus =
-  let doc = "CPUids to provision" in
-  Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
-
-let vms =
-  let doc = "Number of VMs to provision" in
-  Arg.(required & pos 1 (some int) None & info [] ~doc)
-
-let block =
-  let doc = "Block storage to provision" in
-  Arg.(value & opt (some int) None & info [ "block" ] ~doc)
-
-let b =
-  let parse s =
-    match String.cuts ~sep:"/" s with
-    | [ name ; fst ; lst ; gw ; nm ] ->
-      begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
-        | Some fst, Some lst, Some gw ->
-          (try
-             let nm = int_of_string nm in
-             if nm > 0 && nm <= 32 then
-               let net = Ipaddr.V4.Prefix.make nm gw in
-               if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
-                 `Ok (`External (name, fst, lst, gw, nm))
-               else
-                 `Error "first or last IP are not in subnet"
-             else
-               `Error "netmask must be > 0 and <= 32"
-           with Failure _ -> `Error "couldn't parse netmask")
-        | _ -> `Error "couldn't parse IP address"
-      end
-    | [ name ] -> `Ok (`Internal name)
-    | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
-  in
-  (parse, Vmm_core.pp_bridge)
-
-let bridge =
-  let doc = "Bridge to provision" in
-  Arg.(value & opt_all b [] & info [ "bridge" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
-  Term.info "vmm_req_delegation" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_req_permissions.ml

@@ -1,46 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-open Vmm_asn
-
-let cmd_csr name key permissions =
-  let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
-      (false, `Unsupported (Oid.permissions, permissions_to_cstruct permissions)) ]
-  and name = [ `CN name ]
-  in
-  X509.CA.request name ~extensions:[`Extensions exts] key
-
-let jump _ name key permissions =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key key name >>= fun key ->
-    let csr = cmd_csr name key permissions in
-    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
-    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
-
-open Cmdliner
-
-let cmd =
-  let parse s =
-    match Vmm_core.permission_of_string s with
-    | Some x -> `Ok x
-    | None -> `Error "invalid permission"
-  in
-  (parse, Vmm_core.pp_permission)
-
-let permissions =
-  let doc = "permissions" in
-  Arg.(value & opt_all cmd [] & info [ "p" ; "permission" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ permissions)),
-  Term.info "vmm_req_permissions" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_req_vm.ml

@@ -1,85 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-open Vmm_asn
-
-let vm_csr key name image cpu mem args block net force compression =
-  let block = match block with
-    | None -> []
-    | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ]
-  and arg = match args with
-    | [] -> []
-    | xs -> [ (false, `Unsupported (Oid.argv, strings_to_cstruct xs)) ]
-  and net = match net with
-    | [] -> []
-    | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ]
-  and cmd = if force then `Force_create else `Create
-  in
-  let image = match compression with
-    | 0 -> image_to_cstruct (`Ukvm_amd64, image)
-    | level ->
-      let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
-      image_to_cstruct (`Ukvm_amd64_compressed, Cstruct.of_string img)
-  in
-  let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
-      (false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ;
-      (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
-      (false, `Unsupported (Oid.vmimage, image)) ;
-      (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ;
-    ] @ block @ arg @ net
-  and name = [ `CN name ]
-  in
-  X509.CA.request name ~extensions:[`Extensions exts] key
-
-let jump _ name key image mem cpu args block net force compression =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key key name >>= fun key ->
-    (Bos.OS.File.read (Fpath.v image) >>= fun s ->
-     Ok (Cstruct.of_string s)) >>= fun image ->
-    let csr = vm_csr key name image cpu mem args block net force compression in
-    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
-    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
-
-open Cmdliner
-
-let cpu =
-  let doc = "CPUid" in
-  Arg.(required & pos 3 (some int) None & info [] ~doc)
-
-let image =
-  let doc = "Image file to provision" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let args =
-  let doc = "Boot arguments" in
-  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
-
-let block =
-  let doc = "Block device name" in
-  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
-
-let net =
-  let doc = "Network device" in
-  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
-
-let force =
-  let doc = "Force creation (destroy VM with same name if it exists)" in
-  Arg.(value & flag & info [ "force" ] ~doc)
-
-let compress_level =
-  let doc = "Compression level (0 for no compression)" in
-  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
-  Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_revoke.ml

@@ -1,78 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Astring
-
-open Rresult.R.Infix
-
-let jump _ db cacert cakey crl cn serial =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    (match cn, serial with
-     | x, y when x = "" && String.length y > 0 ->
-       (try Ok (Z.of_string y) with Invalid_argument x -> Error (`Msg x))
-     | x, y when y = "" ->
-       Bos.OS.File.read_lines (Fpath.v db) >>= fun entries ->
-       Vmm_core.parse_db entries >>= fun db ->
-       Vmm_core.find_name db x
-     | _ -> Error (`Msg "please provide either common name or serial!")) >>= fun serial ->
-    Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
-    let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
-    Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
-    let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
-
-    let this_update = Ptime_clock.now () in
-    let revoked = { X509.CRL.serial ; date = this_update ; extensions = [] } in
-    let crl = Fpath.v crl in
-    let issuer = X509.subject cacert in
-    (Bos.OS.File.exists crl >>= function
-      | true ->
-        Bos.OS.File.read crl >>= fun crl ->
-        (match X509.Encoding.crl_of_cstruct (Cstruct.of_string crl) with
-         | None -> Error (`Msg "couldn't parse CRL")
-         | Some c -> Ok (X509.CRL.revoke_certificate revoked ~this_update c cakey))
-      | false ->
-        Ok (X509.CRL.revoke
-              ~issuer
-              ~this_update
-              ~extensions:[ (false, `CRL_number 0) ]
-              [ revoked ] cakey)) >>= fun new_crl ->
-    let crl_cs = X509.Encoding.crl_to_cstruct new_crl in
-    Bos.OS.File.write crl (Cstruct.to_string crl_cs) >>= fun () ->
-    (* create temporary certificate for uploading CRL *)
-    let name = "revoke" in
-    priv_key None name >>= fun key ->
-    let csr = X509.CA.request [ `CN name ] key in
-    let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ;
-                       (false, `Unsupported (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Crl ])) ;
-                       (false, `Unsupported (Vmm_asn.Oid.crl, crl_cs)) ] @ l_exts
-    in
-    sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg e) -> `Error (false, e)
-
-open Cmdliner
-
-let key =
-  let doc = "Private key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let crl =
-  let doc = "Revocation list" in
-  Arg.(required & pos 3 (some file) None & info [] ~doc)
-
-let cn =
-  let doc = "Common Name" in
-  Arg.(value & opt string "" & info [ "cn" ] ~doc)
-
-let serial =
-  let doc = "Serial" in
-  Arg.(value & opt string "" & info [ "serial" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ db $ cacert $ key $ crl $ cn $ serial)),
-  Term.info "vmm_revoke" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_sign.ml

@@ -1,298 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-open Astring
-
-let has oid exts =
-  List.exists (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts
-
-let req oid exts f =
-  try
-    let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
-    match ext with
-    | (_, `Unsupported (_, y)) -> f y
-    | _ -> Error (`Msg "not found")
-  with Not_found -> Error (`Msg "not found")
-
-let opt oid exts f =
-  try
-    let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
-    match ext with
-    | (_, `Unsupported (_, y)) -> f y >>= fun x -> Ok (Some x)
-    | _ -> Ok None
-  with Not_found -> Ok None
-
-let sign dbname cacert key csr days =
-  let ri = X509.CA.info csr in
-  Logs.app (fun m -> m "signing certificate with subject %s"
-               (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
-  let issuer = X509.subject cacert in
-  (* TODO: handle version mismatch of the delegation cert specially here *)
-  let delegation = match Vmm_asn.delegation_of_cert asn_version cacert with
-    | Ok d -> Some d
-    | Error _ -> None
-  in
-  Logs.app (fun m -> m "using delegation %s: %a" (X509.distinguished_name_to_string issuer)
-               Fmt.(option ~none:(unit "no") Vmm_core.pp_delegation) delegation) ;
-  let req_exts =
-    match
-      List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions
-    with
-    | exception Not_found -> []
-    | `Extensions x -> x
-    | _ -> []
-  in
-  req Vmm_asn.Oid.version req_exts Vmm_asn.version_of_cstruct >>= fun v ->
-  (if Vmm_asn.version_eq v asn_version then
-     Ok ()
-   else
-     Error (`Msg "unknown version in request")) >>= fun () ->
-  let s_exts = [ (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct v) ] in
-  let get_int () =
-    let id = read_line () in
-    (try Ok (int_of_string id) with
-     | Failure _ -> Error (`Msg "couldn't parse integer"))
-  in
-  (match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with
-   | true, false -> Ok `Vm
-   | false, true -> Ok `Delegation
-   | false, false -> Ok `Permission
-   | _ -> Error (`Msg "cannot categorise signing request")) >>= (function
-      | `Vm ->
-        Logs.app (fun m -> m "categorised as a virtual machine request") ;
-        req Vmm_asn.Oid.vmimage req_exts Vmm_asn.image_of_cstruct >>= fun (typ, img) ->
-        Logs.app (fun m -> m "image of type %a, size %d" Vmm_core.pp_vmtype typ (Cstruct.len img)) ;
-        let s_exts = (Vmm_asn.Oid.vmimage, Vmm_asn.image_to_cstruct (typ, img)) :: s_exts in
-        let cpuids = match delegation with
-          | None -> None
-          | Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids)
-        in
-        (opt Vmm_asn.Oid.cpuid req_exts Vmm_asn.int_of_cstruct >>= function
-          | None ->
-            Logs.warn (fun m -> m "no CPU specified, please specify one of %a: "
-                          Fmt.(option ~none:(unit "??") (list ~sep:(unit ",") int)) cpuids) ;
-            get_int () >>= fun cpu ->
-            (match cpuids with
-             | None -> Ok cpu
-             | Some x when List.mem cpu x -> Ok cpu
-             | Some _ -> Error (`Msg "refusing to use a not-delegated CPU"))
-          | Some cpu ->
-            match cpuids with
-            | None -> Ok cpu
-            | Some x when List.mem cpu x -> Ok cpu
-            | Some x ->
-              Logs.err (fun m -> m "CPU id %d was requested, which is not delegated, please specify one of %a:"
-                           cpu Fmt.(list ~sep:(unit ",") int) x) ;
-              get_int () >>= fun cpu ->
-              if List.mem cpu x then Ok cpu
-              else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid ->
-        Logs.app (fun m -> m "using CPU %d" cpuid) ;
-        let s_exts = (Vmm_asn.Oid.cpuid, Vmm_asn.int_to_cstruct cpuid) :: s_exts in
-        let memory = match delegation with
-          | None -> None
-          | Some x -> Some x.Vmm_core.memory
-        in
-        (opt Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= function
-          | None ->
-            Logs.warn (fun m -> m "no memory specified, please specify amount (max %a):"
-                          Fmt.(option ~none:(unit "??") int) memory) ;
-            get_int () >>= fun m ->
-            (match memory with
-             | None -> Ok m
-             | Some x when m <= x -> Ok m
-             | Some _ -> Error (`Msg "refusing to overcommit memory"))
-          | Some me ->
-            match memory with
-            | None -> Ok me
-            | Some x when me < x -> Ok me
-            | Some x ->
-              Logs.err (fun m -> m "you have %d memory delegated, but %d is requested, please specify a smaller amount:" x me) ;
-              get_int () >>= fun m ->
-              if m <= x then Ok m
-              else Error (`Msg "refusing to use that much memory")) >>= fun mem ->
-        Logs.app (fun m -> m "using %d memory" mem) ;
-        let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
-        (opt Vmm_asn.Oid.network req_exts Vmm_asn.strings_of_cstruct >>= function
-          | None -> Ok None
-          | Some [] -> Ok None
-          | Some x ->
-            match delegation with
-            | None -> Ok (Some x)
-            | Some del ->
-              let bridges = del.Vmm_core.bridges in
-              List.fold_left (fun r x ->
-                  r >>= fun () -> match String.Map.find x bridges with
-                  | None ->
-                    Rresult.R.error_msgf
-                      "won't get you a network interface on bridge %s, which is not delegated." x
-                  | Some _ -> Ok ())
-                (Ok ()) x >>= fun () ->
-              Ok (Some x)) >>= fun net ->
-        Logs.app (fun m -> m "using network interfaces %a"
-                     Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") string)) net) ;
-        let s_exts =
-          match net with
-          | None -> s_exts
-          | Some n -> (Vmm_asn.Oid.network, Vmm_asn.strings_to_cstruct n) :: s_exts
-        in
-        (opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function
-          | None -> Ok None
-          | Some x ->
-            match delegation with
-            | None -> Ok (Some x)
-            | Some d -> match d.Vmm_core.block with
-              | None -> Error (`Msg "trying to use a block device, when no block storage is delegated")
-              | Some _ -> Ok (Some x)) >>= fun block_device ->
-        Logs.app (fun m -> m "using block device %a"
-                     Fmt.(option ~none:(unit "none") string) block_device) ;
-        let s_exts = match block_device with
-          | None -> s_exts
-          | Some x -> (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct x) :: s_exts
-        in
-        opt Vmm_asn.Oid.argv req_exts Vmm_asn.strings_of_cstruct >>= fun argv ->
-        Logs.app (fun m -> m "using argv %a"
-                     Fmt.(option ~none:(unit "none")
-                            (list ~sep:(unit ", ") string)) argv) ;
-        let s_exts = match argv with
-          | None -> s_exts
-          | Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts
-        in
-        opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms ->
-        Logs.app (fun m -> m "using permission %a"
-                     Fmt.(option ~none:(unit "none")
-                            (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ;
-        let perm = match perms with
-          | Some [ `Force_create ] -> [ `Force_create ]
-          | Some [ `Create ] -> [ `Create ]
-          | _ ->
-            Logs.warn (fun m -> m "weird permissions (%a), replaced with create"
-                          Fmt.(option ~none:(unit "none")
-                                 (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ;
-            [ `Create ]
-        in
-        let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perm) :: s_exts in
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        Ok (exts @ l_exts)
-      | `Delegation ->
-        (req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x ->
-         match delegation with
-         | None -> Ok x
-         | Some d when Vmm_core.IS.subset d.Vmm_core.cpuids (Vmm_core.IS.of_list x) -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "CPUs %a are not a subset of the delegated ones %a"
-                       Fmt.(list ~sep:(unit ",") int) x
-                       Fmt.(list ~sep:(unit ",") int) (Vmm_core.IS.elements d.Vmm_core.cpuids)) >>= fun cpuids ->
-        Logs.app (fun m -> m "delegating CPUs %a" Fmt.(list ~sep:(unit ",") int) cpuids) ;
-        let s_exts = (Vmm_asn.Oid.cpuids, Vmm_asn.ints_to_cstruct cpuids) :: s_exts in
-        (req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= fun x ->
-         match delegation with
-         | None -> Ok x
-         | Some d when d.Vmm_core.memory >= x -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "cannot delegate %d memory, only have %d delegated" x d.Vmm_core.memory) >>= fun mem ->
-        Logs.app (fun m -> m "delegating %d memory" mem) ;
-        let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
-        (opt Vmm_asn.Oid.block req_exts Vmm_asn.int_of_cstruct >>= function
-          | None -> Ok None
-          | Some x when x = 0 -> Ok None
-          | Some x -> match delegation with
-            | None -> Ok (Some x)
-            | Some d -> match d.Vmm_core.block with
-              | None -> Error (`Msg "cannot delegate block storage, don't have any delegated")
-              | Some d when d >= x -> Ok (Some x)
-              | Some d -> Rresult.R.error_msgf
-                            "cannot delegate %d block storage, only have %d delegated" x d) >>= fun bl ->
-        Logs.app (fun m -> m "delegating %a block storage" Fmt.(option ~none:(unit "none") int) bl) ;
-        let s_exts = match bl with
-          | None -> s_exts
-          | Some x -> (Vmm_asn.Oid.block, Vmm_asn.int_to_cstruct x) :: s_exts
-        in
-        (req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x ->
-         match delegation with
-         | None -> Ok x
-         | Some d when d.Vmm_core.vms >= x -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "cannot delegate %d vms, only have %d delegated" x d.Vmm_core.vms) >>= fun vm ->
-        Logs.app (fun m -> m "delegating %d vms" vm) ;
-        let s_exts = (Vmm_asn.Oid.vms, Vmm_asn.int_to_cstruct vm) :: s_exts in
-        (opt Vmm_asn.Oid.bridges req_exts Vmm_asn.bridges_of_cstruct >>= function
-          | None -> Ok None
-          | Some xs when xs = [] -> Ok None
-          | Some xs -> match delegation with
-            | None -> Ok (Some xs)
-            | Some x ->
-              let sub =
-                let add m v =
-                  let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
-                  String.Map.add n v m
-                in
-                List.fold_left add String.Map.empty xs
-              in
-              if Vmm_core.sub_bridges x.Vmm_core.bridges sub then Ok (Some xs)
-              else Error (`Msg "cannot delegate bridges which are not delegated in this ca cert")) >>= fun bridges ->
-        Logs.app (fun m -> m "delegating bridges: %a"
-                     Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") Vmm_core.pp_bridge))
-                     bridges) ;
-        let s_exts = match bridges with
-          | None -> s_exts
-          | Some b -> (Vmm_asn.Oid.bridges, Vmm_asn.bridges_to_cstruct b) :: s_exts
-        in
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        let pl = match X509.Extension.basic_constraints cacert with
-          | None -> None
-          | Some (true, n) -> Some n
-          | Some (false, _) -> None
-        in
-        Logs.app (fun m -> m "how much deeper should delegate be able to share? (max %a)"
-                     Fmt.(option ~none:(unit "??") (option ~none:(unit "unlimited") int)) pl) ;
-        get_int () >>= fun len ->
-        (match pl with
-         | None | Some None -> Ok ()
-         | Some (Some x) when x >= succ len -> Ok ()
-         | Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () ->
-        Ok (exts @ d_exts ~len ())
-      | `Permission ->
-        req Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms ->
-        Logs.app (fun m -> m "an interactive certificate with permissions %a"
-                     Fmt.(list ~sep:(unit ", ") Vmm_core.pp_permission) perms) ;
-        let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perms) :: s_exts in
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        Ok (exts @ l_exts)) >>= fun extensions ->
-  sign ~dbname extensions issuer key csr (Duration.of_day days)
-
-let jump _ db cacert cakey csrname days =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
-    let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
-    Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
-    let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
-    Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
-    let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
-    sign (Fpath.v db) cacert cakey csr days
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg e) -> `Error (false, e)
-
-open Cmdliner
-
-let csr =
-  let doc = "signing request" in
-  Arg.(required & pos 3 (some file) None & info [] ~doc)
-
-let days =
-  let doc = "Number of days" in
-  Arg.(value & opt int 1 & info [ "days" ] ~doc)
-
-let key =
-  let doc = "Private key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)),
-  Term.info "vmm_sign" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

src/vmm_asn.ml

@@ -1,53 +1,12 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Vmm_core
+open Vmm_commands
 
 open Rresult
 open Astring
 
-module Oid = struct
-  open Asn.OID
-
-  let m = base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42
-
-  let version = m <| 0
-
-  (* used only in CA certs *)
-  let vms = m <| 1
-  let bridges = m <| 2
-  let block = m <| 3
-  let cpuids = m <| 4
-  (* TODO: embed host URL (well, or use common name / SubjectAlternativeName with IP, and static port?) *)
-
-  (* used in both CA and VM certs *)
-  let memory = m <| 5
-
-  (* used only in VM certs *)
-  let cpuid = m <| 6
-  let network = m <| 7
-  let block_device = m <| 8
-  let vmimage = m <| 9
-  let argv = m <| 10
-
-  (* used in VM certs and other leaf certs *)
-  let permissions = m <| 42
-
-  (* used in CRL certs *)
-  let crl = m <| 43
-end
-
-let perms : permission list Asn.t =
-  Asn.S.bit_string_flags [
-    0, `All ;
-    1, `Info ;
-    2, `Create ;
-    3, `Block ;
-    4, `Statistics ;
-    5, `Console ;
-    6, `Log ;
-    7, `Crl ;
-    9, `Force_create ;
-  ]
+let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42)
 
 open Rresult.R.Infix
 
@@ -64,9 +23,6 @@ let projections_of asn =
   let c = Asn.codec Asn.der asn in
   (decode_strict c, Asn.encode c)
 
-let int_of_cstruct, int_to_cstruct = projections_of Asn.S.int
-let ints_of_cstruct, ints_to_cstruct = projections_of Asn.S.(sequence_of int)
-
 let ipv4 =
   let f cs = Ipaddr.V4.of_bytes_exn (Cstruct.to_string cs)
   and g ip = Cstruct.of_string (Ipaddr.V4.to_bytes ip)
@@ -91,86 +47,10 @@ let bridge =
                           (required ~label:"router" ipv4)
                           (required ~label:"netmask" int))))
 
-let bridges_of_cstruct, bridges_to_cstruct =
-  projections_of (Asn.S.sequence_of bridge)
-
-let strings_of_cstruct, strings_to_cstruct =
-  projections_of Asn.S.(sequence_of utf8_string)
-
-let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string
-
-let image =
-  let f = function
-    | `C1 x -> `Ukvm_amd64, x
-    | `C2 x -> `Ukvm_arm64, x
-    | `C3 x -> `Ukvm_amd64_compressed, x
-  and g = function
-    | `Ukvm_amd64, x -> `C1 x
-    | `Ukvm_arm64, x -> `C2 x
-    | `Ukvm_amd64_compressed, x -> `C3 x
-  in
-  Asn.S.map f g @@
-  Asn.S.(choice3
-           (explicit 0 octet_string)
-           (explicit 1 octet_string)
-           (explicit 2 octet_string))
-
-let image_of_cstruct, image_to_cstruct = projections_of image
-
-let permissions_of_cstruct, permissions_to_cstruct = projections_of perms
-
-let req label cert oid f =
-  match X509.Extension.unsupported cert oid with
-  | None -> R.error_msgf "OID %s not present (%a)" label Asn.OID.pp oid
-  | Some (_, data) -> f data
-
-let opt cert oid f =
-  match X509.Extension.unsupported cert oid with
-  | None -> Ok None
-  | Some (_, data) -> f data >>| fun s -> Some s
-
-type version = [ `AV0 ]
-
-let version_of_int = function
-  | 0 -> Ok `AV0
-  | _ -> Error (`Msg "couldn't parse version")
-
-let version_to_int = function
-  | `AV0 -> 0
-
-let pp_version ppf v =
-  Fmt.int ppf
-    (match v with
-     | `AV0 -> 0)
-
-let version_eq a b =
-  match a, b with
-  | `AV0, `AV0 -> true
-
-let version_to_cstruct v = int_to_cstruct (version_to_int v)
-
-let version_of_cstruct cs =
-  int_of_cstruct cs >>= fun v ->
-  version_of_int v
-
-let version_of_cert version cert =
-  req "version" cert Oid.version version_of_cstruct >>= fun version' ->
-  if version_eq version version' then
-    Ok ()
-  else
-    R.error_msgf "unsupported asn version %a (expected %a)"
-      pp_version version' pp_version version
-
-let delegation_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids ->
-  req "memory" cert Oid.memory int_of_cstruct >>= fun memory ->
-  opt cert Oid.block int_of_cstruct >>= fun block ->
-  req "vms" cert Oid.vms int_of_cstruct >>= fun vms ->
-  opt cert Oid.bridges bridges_of_cstruct >>= fun bridges ->
+let policy =
+  let f (cpuids, vms, memory, block, bridges) =
     let bridges = match bridges with
-    | None -> String.Map.empty
-    | Some xs ->
+      | xs ->
         let add m v =
           let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
           String.Map.add n v m
@@ -178,36 +58,413 @@ let delegation_of_cert version cert =
         List.fold_left add String.Map.empty xs
     and cpuids = IS.of_list cpuids
     in
-  Ok { vms ; cpuids ; memory ; block ; bridges }
-
-let contains_vm cert =
-  match X509.Extension.unsupported cert Oid.vmimage with
-  | None -> false
-  | Some _ -> true
-
-let contains_crl cert =
-  match X509.Extension.unsupported cert Oid.crl with
-  | None -> false
-  | Some _ -> true
-
-let crl_of_cert cert =
-  let crl cs = match X509.Encoding.crl_of_cstruct cs with
-    | None -> Error (`Msg "couldn't parse revocation list")
-    | Some x -> Ok x
+    { vms ; cpuids ; memory ; block ; bridges }
+  and g policy =
+    (IS.elements policy.cpuids, policy.vms, policy.memory, policy.block,
+     snd @@ List.split @@ String.Map.bindings policy.bridges)
   in
-  req "crl" cert Oid.crl crl
+  Asn.S.map f g @@
+  Asn.S.(sequence5
+           (required ~label:"cpuids" Asn.S.(sequence_of int))
+           (required ~label:"vms" int)
+           (required ~label:"memory" int)
+           (optional ~label:"block" int)
+           (required ~label:"bridges" Asn.S.(sequence_of bridge)))
 
-let vm_of_cert prefix cert =
-  req "cpuid" cert Oid.cpuid int_of_cstruct >>= fun cpuid ->
-  req "memory" cert Oid.memory int_of_cstruct >>= fun requested_memory ->
-  opt cert Oid.block_device string_of_cstruct >>= fun block_device ->
-  opt cert Oid.network strings_of_cstruct >>= fun network ->
-  req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
-  opt cert Oid.argv strings_of_cstruct >>= fun argv ->
-  let vname = id cert in
-  let network = match network with None -> [] | Some x -> x in
-  Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
+let image =
+  let f = function
+    | `C1 x -> `Hvt_amd64, x
+    | `C2 x -> `Hvt_arm64, x
+    | `C3 x -> `Hvt_amd64_compressed, x
+  and g = function
+    | `Hvt_amd64, x -> `C1 x
+    | `Hvt_arm64, x -> `C2 x
+    | `Hvt_amd64_compressed, x -> `C3 x
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+           (explicit 0 octet_string)
+           (explicit 1 octet_string)
+           (explicit 2 octet_string))
 
-let permissions_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "permissions" cert Oid.permissions permissions_of_cstruct
+let console_cmd =
+  let f = function
+    | `C1 () -> `Console_add
+    | `C2 ts -> `Console_subscribe ts
+  and g = function
+    | `Console_add -> `C1 ()
+    | `Console_subscribe ts -> `C2 ts
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice2
+           (explicit 0 null)
+           (explicit 1 (sequence (single (optional ~label:"since" utc_time)))))
+
+(* TODO is this good? *)
+let int64 =
+  let f cs = Cstruct.BE.get_uint64 cs 0
+  and g data =
+    let buf = Cstruct.create 8 in
+    Cstruct.BE.set_uint64 buf 0 data ;
+    buf
+  in
+  Asn.S.map f g Asn.S.octet_string
+
+let timeval =
+  Asn.S.(sequence2
+           (required ~label:"seconds" int64)
+           (required ~label:"microseconds" int))
+
+let ru =
+  let open Stats in
+  let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) =
+    { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
+  and g ru =
+    (ru.utime, (ru.stime, (ru.maxrss, (ru.ixrss, (ru.idrss, (ru.isrss, (ru.minflt, (ru.majflt, (ru.nswap, (ru.inblock, (ru.outblock, (ru.msgsnd, (ru.msgrcv, (ru.nsignals, (ru.nvcsw, ru.nivcsw)))))))))))))))
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence @@
+           (required ~label:"utime" timeval)
+         @ (required ~label:"stime" timeval)
+         @ (required ~label:"maxrss" int64)
+         @ (required ~label:"ixrss" int64)
+         @ (required ~label:"idrss" int64)
+         @ (required ~label:"isrss" int64)
+         @ (required ~label:"minflt" int64)
+         @ (required ~label:"majflt" int64)
+         @ (required ~label:"nswap" int64)
+         @ (required ~label:"inblock" int64)
+         @ (required ~label:"outblock" int64)
+         @ (required ~label:"msgsnd" int64)
+         @ (required ~label:"msgrcv" int64)
+         @ (required ~label:"nsignals" int64)
+         @ (required ~label:"nvcsw" int64)
+        -@ (required ~label:"nivcsw" int64))
+
+(* TODO is this good? *)
+let int32 =
+  let f i = Int32.of_int i
+  and g i = Int32.to_int i
+  in
+  Asn.S.map f g Asn.S.int
+
+let ifdata =
+  let open Stats in
+  let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
+    { name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
+  and g i =
+    (i.name, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped)))))))))))))))))
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence @@
+         (required ~label:"name" utf8_string)
+       @ (required ~label:"flags" int32)
+       @ (required ~label:"send_length" int32)
+       @ (required ~label:"max_send_length" int32)
+       @ (required ~label:"send_drops" int32)
+       @ (required ~label:"mtu" int32)
+       @ (required ~label:"baudrate" int64)
+       @ (required ~label:"input_packets" int64)
+       @ (required ~label:"input_errors" int64)
+       @ (required ~label:"output_packets" int64)
+       @ (required ~label:"output_errors" int64)
+       @ (required ~label:"collisions" int64)
+       @ (required ~label:"input_bytes" int64)
+       @ (required ~label:"output_bytes" int64)
+       @ (required ~label:"input_mcast" int64)
+       @ (required ~label:"output_mcast" int64)
+       @ (required ~label:"input_dropped" int64)
+      -@ (required ~label:"output_dropped" int64))
+
+let stats_cmd =
+  let f = function
+    | `C1 (pid, taps) -> `Stats_add (pid, taps)
+    | `C2 () -> `Stats_remove
+    | `C3 () -> `Stats_subscribe
+  and g = function
+    | `Stats_add (pid, taps) -> `C1 (pid, taps)
+    | `Stats_remove -> `C2 ()
+    | `Stats_subscribe -> `C3 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+           (explicit 0 (sequence2
+                          (required ~label:"pid" int)
+                          (required ~label:"taps" (sequence_of utf8_string))))
+           (explicit 1 null)
+           (explicit 2 null))
+
+let log_event =
+  let f = function
+    | `C1 () -> `Startup
+    | `C2 (name, ip, port) -> `Login (name, ip, port)
+    | `C3 (name, ip, port) -> `Logout (name, ip, port)
+    | `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block)
+    | `C5 (name, pid, status) ->
+      let status' = match status with
+        | `C1 n -> `Exit n
+        | `C2 n -> `Signal n
+        | `C3 n -> `Stop n
+      in
+      `Vm_stop (name, pid, status')
+  and g = function
+    | `Startup -> `C1 ()
+    | `Login (name, ip, port) -> `C2 (name, ip, port)
+    | `Logout (name, ip, port) -> `C3 (name, ip, port)
+    | `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block)
+    | `Vm_stop (name, pid, status) ->
+      let status' = match status with
+        | `Exit n -> `C1 n
+        | `Signal n -> `C2 n
+        | `Stop n -> `C3 n
+      in
+      `C5 (name, pid, status')
+  in
+  let endp =
+    Asn.S.(sequence3
+            (required ~label:"name" (sequence_of utf8_string))
+            (required ~label:"ip" ipv4)
+            (required ~label:"port" int))
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice5
+           (explicit 0 null)
+           (explicit 1 endp)
+           (explicit 2 endp)
+           (explicit 3 (sequence4
+                         (required ~label:"name" (sequence_of utf8_string))
+                         (required ~label:"pid" int)
+                         (required ~label:"taps" (sequence_of utf8_string))
+                         (optional ~label:"block" utf8_string)))
+           (explicit 4 (sequence3
+                          (required ~label:"name" (sequence_of utf8_string))
+                          (required ~label:"pid" int)
+                          (required ~label:"status" (choice3
+                                                       (explicit 0 int)
+                                                       (explicit 1 int)
+                                                       (explicit 2 int))))))
+
+let log_cmd =
+  let f = function
+    | ts -> `Log_subscribe ts
+  and g = function
+    | `Log_subscribe ts -> ts
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence (single (optional ~label:"since" utc_time)))
+
+let vm_config =
+  let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
+    let network = match network with None -> [] | Some xs -> xs in
+    { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
+  and g vm =
+    let network = match vm.network with [] -> None | xs -> Some xs in
+    (vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv)
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence6
+           (required ~label:"cpu" int)
+           (required ~label:"memory" int)
+           (optional ~label:"block" utf8_string)
+           (optional ~label:"bridges" (sequence_of utf8_string))
+           (required ~label:"vmimage" image)
+           (optional ~label:"arguments" (sequence_of utf8_string)))
+
+let vm_cmd =
+  let f = function
+    | `C1 () -> `Vm_info
+    | `C2 vm -> `Vm_create vm
+    | `C3 vm -> `Vm_force_create vm
+    | `C4 () -> `Vm_destroy
+  and g = function
+    | `Vm_info -> `C1 ()
+    | `Vm_create vm -> `C2 vm
+    | `Vm_force_create vm -> `C3 vm
+    | `Vm_destroy -> `C4 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice4
+           (explicit 0 null)
+           (explicit 1 vm_config)
+           (explicit 2 vm_config)
+           (explicit 3 null))
+
+let policy_cmd =
+  let f = function
+    | `C1 () -> `Policy_info
+    | `C2 policy -> `Policy_add policy
+    | `C3 () -> `Policy_remove
+  and g = function
+    | `Policy_info -> `C1 ()
+    | `Policy_add policy -> `C2 policy
+    | `Policy_remove -> `C3 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+           (explicit 0 null)
+           (explicit 1 policy)
+           (explicit 2 null))
+
+let version =
+  let f data = match data with
+    | 2 -> `AV2
+    | _ -> Asn.S.error (`Parse "unknown version number")
+  and g = function
+    | `AV2 -> 2
+  in
+  Asn.S.map f g Asn.S.int
+
+let wire_command =
+  let f = function
+    | `C1 console -> `Console_cmd console
+    | `C2 stats -> `Stats_cmd stats
+    | `C3 log -> `Log_cmd log
+    | `C4 vm -> `Vm_cmd vm
+    | `C5 policy -> `Policy_cmd policy
+  and g = function
+    | `Console_cmd c -> `C1 c
+    | `Stats_cmd c -> `C2 c
+    | `Log_cmd c -> `C3 c
+    | `Vm_cmd c -> `C4 c
+    | `Policy_cmd c -> `C5 c
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice5
+           (explicit 0 console_cmd)
+           (explicit 1 stats_cmd)
+           (explicit 2 log_cmd)
+           (explicit 3 vm_cmd)
+           (explicit 4 policy_cmd))
+
+let data =
+  let f = function
+    | `C1 (timestamp, data) -> `Console_data (timestamp, data)
+    | `C2 (ru, ifs, vmm) -> `Stats_data (ru, vmm, ifs)
+    | `C3 (timestamp, event) -> `Log_data (timestamp, event)
+  and g = function
+    | `Console_data (timestamp, data) -> `C1 (timestamp, data)
+    | `Stats_data (ru, ifs, vmm) -> `C2 (ru, vmm, ifs)
+    | `Log_data (timestamp, event) -> `C3 (timestamp, event)
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+           (explicit 0 (sequence2
+                          (required ~label:"timestamp" utc_time)
+                          (required ~label:"data" utf8_string)))
+           (explicit 1 (sequence3
+                          (required ~label:"resource_usage" ru)
+                          (required ~label:"ifdata" (sequence_of ifdata))
+                          (optional ~label:"vmm_stats"
+                             (sequence_of (sequence2
+                                             (required ~label:"key" utf8_string)
+                                             (required ~label:"value" int64))))))
+           (explicit 2 (sequence2
+                          (required ~label:"timestamp" utc_time)
+                          (required ~label:"event" log_event))))
+
+let header =
+  let f (version, sequence, id) = { version ; sequence ; id }
+  and g h = h.version, h.sequence, h.id
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence3
+           (required ~label:"version" version)
+           (required ~label:"sequence" int64)
+           (required ~label:"id" (sequence_of utf8_string)))
+
+let success =
+  let f = function
+    | `C1 () -> `Empty
+    | `C2 str -> `String str
+    | `C3 policies -> `Policies policies
+    | `C4 vms -> `Vms vms
+  and g = function
+    | `Empty -> `C1 ()
+    | `String s -> `C2 s
+    | `Policies ps -> `C3 ps
+    | `Vms vms -> `C4 vms
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice4
+           (explicit 0 null)
+           (explicit 1 utf8_string)
+           (explicit 2 (sequence_of
+                          (sequence2
+                             (required ~label:"name" (sequence_of utf8_string))
+                             (required ~label:"policy" policy))))
+           (explicit 3 (sequence_of
+                          (sequence2
+                             (required ~label:"name" (sequence_of utf8_string))
+                             (required ~label:"vm_config" vm_config)))))
+
+let payload =
+  let f = function
+    | `C1 cmd -> `Command cmd
+    | `C2 s -> `Success s
+    | `C3 str -> `Failure str
+    | `C4 data -> `Data data
+  and g = function
+    | `Command cmd -> `C1 cmd
+    | `Success s -> `C2 s
+    | `Failure str -> `C3 str
+    | `Data d -> `C4 d
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice4
+           (explicit 0 wire_command)
+           (explicit 1 success)
+           (explicit 2 utf8_string)
+           (explicit 3 data))
+
+let wire =
+  Asn.S.(sequence2
+           (required ~label:"header" header)
+           (required ~label:"payload" payload))
+
+let wire_of_cstruct, wire_to_cstruct = projections_of wire
+
+let log_entry =
+  Asn.S.(sequence2
+           (required ~label:"timestamp" utc_time)
+           (required ~label:"event" log_event))
+
+let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
+
+let log_disk =
+  Asn.S.(sequence2
+           (required ~label:"version" version)
+           (required ~label:"entry" log_entry))
+
+let log_disk_of_cstruct, log_disk_to_cstruct =
+  let c = Asn.codec Asn.der log_disk in
+  (Asn.decode c, Asn.encode c)
+
+let log_to_disk version entry =
+  log_disk_to_cstruct (version, entry)
+
+let logs_of_disk version buf =
+  let rec next acc buf =
+    match log_disk_of_cstruct buf with
+    | Ok ((version', entry), cs) ->
+      let acc' =
+        if Vmm_commands.version_eq version version' then
+          entry :: acc
+        else
+          acc
+      in
+      next acc' cs
+    | Error (`Parse msg) ->
+      Logs.warn (fun m -> m "parse error %s while parsing log" msg) ;
+      acc (* ignore *)
+  in
+  next [] buf
+
+type cert_extension = version * t
+
+let cert_extension =
+  Asn.S.(sequence2
+           (required ~label:"version" version)
+           (required ~label:"command" wire_command))
+
+let cert_extension_of_cstruct, cert_extension_to_cstruct =
+  projections_of cert_extension

src/vmm_asn.mli

@@ -1,161 +1,27 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Vmm_core
 
 (** ASN.1 encoding of resources and configuration *)
 
-(** Object Identifiers *)
+(** {1 Object Identifier} *)
 
-module Oid : sig
+(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *)
+val oid : Asn.OID.t
 
-  (** {1 Object identifiers} *)
+val wire_to_cstruct : Vmm_commands.wire -> Cstruct.t
 
-  (** OIDs in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.42) *)
+val wire_of_cstruct : Cstruct.t -> (Vmm_commands.wire, [> `Msg of string ]) result
 
-  (** [version] specifies an [INTEGER] describing the version. *)
-  val version : Asn.OID.t
+val log_entry_to_cstruct : Log.t -> Cstruct.t
 
-  (** {2 OIDs used in delegation certificates} *)
+val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result
 
-  (** [vms] is an [INTEGER] denoting the number of virtual machines. *)
-  val vms : Asn.OID.t
+val log_to_disk : Vmm_commands.version -> Log.t -> Cstruct.t
 
-  (** [bridges] is a [CHOICE] between [ [0] UTF8STRING], describing an internal
-      bridge, and a [ [1] SEQUENCE] of [UTF8STRING], [IPV4ADDRESS] denoting the first
-      IP to use, [IPV4ADDRESS] denoting the last IP to use, [IPV4ADDRESS]
-      denoting the default gateway, [INTEGER] denoting the netmask. *)
-  val bridges : Asn.OID.t
+val logs_of_disk : Vmm_commands.version -> Cstruct.t -> Log.t list
 
-  (** [block] is an [INTEGER] denoting the size of block storage available for
-      this delegation in MB. *)
-  val block : Asn.OID.t
+type cert_extension = Vmm_commands.version * Vmm_commands.t
 
-  (** [cpuids] is a [SEQUENCE OF INTEGER] denoting the CPU identifiers available
-      for this delegate. *)
-  val cpuids : Asn.OID.t
-
-  (** [memory] is an [INTEGER] denoting the amount of available memory, in
-      MB.  Also used in virtual machine certificates. *)
-  val memory : Asn.OID.t
-
-  (** {2 OIDs used in virtual machine certificates} *)
-
-  (** [cpuid] is an [INTEGER] denoting the CPU identifier on which this virtual
-      machine should be executed.  Must be a member of all [cpuids] in the
-      chained delegation certificates. *)
-  val cpuid : Asn.OID.t
-
-  (** [network] is a [SEQUENCE OF UTF8STRING] denoting the bridge devices to
-      hook this virtual machine up to.  Each name must be in the chained
-      delegation certificates. *)
-  val network : Asn.OID.t
-
-  (** [block_device] is a [UTF8STRING] with the name of the block device.  It
-      must exist. *)
-  val block_device : Asn.OID.t
-
-  (** [vmimage] is a [CHOICE] between [ [0] OCTET_STRING] for an UKVM amd64
-      image and [ [1] OCTET_STRING] for an UKVM arm64 image. *)
-  val vmimage : Asn.OID.t
-
-  (** [argv] is a [SEQUENCE OF UTF8STRING] denoting the boot parameters passed
-      to the virtual machine image. *)
-  val argv : Asn.OID.t
-
-  (** {2 OID used in administrative certificates} *)
-
-  (** [permissions] is a [BIT_STRING] denoting the permissions this certificate
-      has: 0 for All, 1 for Info, 2 for Image, 3 for Block, 4 for Statistics, 5
-      for Console, 6 for Log. *)
-  val permissions : Asn.OID.t
-
-
-  (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate
-      CA. *)
-  val crl : Asn.OID.t
-end
-
-(** {1 Encoding and decoding functions} *)
-
-(** The type of versions of the ASN.1 grammar defined above. *)
-type version = [ `AV0 ]
-
-(** [version_eq a b] is true if [a] and [b] are equal. *)
-val version_eq : version -> version -> bool
-
-(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
-val pp_version : version Fmt.t
-
-(** [version_to_cstruct ver] is the DER encoded version. *)
-val version_to_cstruct : version -> Cstruct.t
-
-(** [version_of_cstruct buffer] is either a decoded version of the DER
-    encoding [buffer] or an error. *)
-val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result
-
-(** [permissions_to_cstruct perms] is the DER encoded permission list. *)
-val permissions_to_cstruct : Vmm_core.permission list -> Cstruct.t
-
-(** [permissions_of_cstruct buffer] is either a decoded permissions list of
-    the DER encoded [buffer] or an error. *)
-val permissions_of_cstruct : Cstruct.t -> (Vmm_core.permission list, [> `Msg of string ]) result
-
-(** [bridges_to_cstruct bridges] is the DER encoded bridges. *)
-val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t
-
-(** [bridges_of_cstruct buffer] is either a decoded bridge list of the DER
-    encoded [buffer] or an error. *)
-val bridges_of_cstruct : Cstruct.t -> (Vmm_core.bridge list, [> `Msg of string ]) result
-
-(** [image_to_cstruct (typ, img)] is the DER encoded image. *)
-val image_to_cstruct : Vmm_core.vmtype * Cstruct.t -> Cstruct.t
-
-(** [image_of_cstruct buffer] is either a decoded image of the DER encoded
-    [buffer] or an error. *)
-val image_of_cstruct : Cstruct.t -> (Vmm_core.vmtype * Cstruct.t, [> `Msg of string ]) result
-
-(** [int_to_cstruct i] is the DER encoded int. *)
-val int_to_cstruct : int -> Cstruct.t
-
-(** [int_of_cstruct buffer] is either a decoded int of the DER encoded [buffer]
-    or an error. *)
-val int_of_cstruct : Cstruct.t -> (int, [> `Msg of string ]) result
-
-(** [ints_to_cstruct xs] is the DER encoded int sequence. *)
-val ints_to_cstruct : int list -> Cstruct.t
-
-(** [ints_of_cstruct buffer] is either a decoded int list of the DER encoded
-    [buffer] or an error. *)
-val ints_of_cstruct : Cstruct.t -> (int list, [> `Msg of string ]) result
-
-(** [string_to_cstruct s] is the DER encoded string. *)
-val string_to_cstruct : string -> Cstruct.t
-
-(** [string_of_cstruct buffer] is either a decoded string of the DER encoded
-    [buffer] or an error. *)
-val string_of_cstruct : Cstruct.t -> (string, [> `Msg of string ]) result
-
-(** [strings_to_cstruct xs] is the DER encoded string sequence. *)
-val strings_to_cstruct : string list -> Cstruct.t
-
-(** [strings_of_cstruct buffer] is either a decoded string list of the DER
-    encoded [buffer] or an error. *)
-val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result
-
-(** {1 Decoding functions} *)
-
-(** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *)
-val contains_vm : X509.t -> bool
-
-(** [contains_crl cert] is [true] if the certificate contains a revocation list. *)
-val contains_crl : X509.t -> bool
-
-(** [vm_of_cert id cert] is either the decoded virtual machine configuration, or an error. *)
-val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string ]) result
-
-(** [crl_of_cert id cert] is either the decoded revocation list, or an error. *)
-val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result
-
-(** [delegation_of_cert version cert] is either the decoded delegation, or an error. *)
-val delegation_of_cert : version -> X509.t -> (Vmm_core.delegation, [> `Msg of string ]) result
-
-(** [permissions_of_cert version cert] is either the decoded permission list, or an error. *)
-val permissions_of_cert : version -> X509.t -> (Vmm_core.permission list, [> `Msg of string ]) result
+val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
+val cert_extension_to_cstruct : cert_extension -> Cstruct.t

src/vmm_commands.ml

@@ -1,192 +1,134 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Rresult
-(* bits copied over from Bos *)
-(*---------------------------------------------------------------------------
-   Copyright (c) 2014 Daniel C. Bünzli
-
-   Permission to use, copy, modify, and/or distribute this software for any
-   purpose with or without fee is hereby granted, provided that the above
-   copyright notice and this permission notice appear in all copies.
-
-   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-  ---------------------------------------------------------------------------*)
-let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
-
-let err_empty_line = "no command, empty command line"
-let err_file f e = R.error_msgf "%a: %a" Fpath.pp f pp_unix_error e
-
-let rec openfile fn mode perm = try Unix.openfile fn mode perm with
-  | Unix.Unix_error (Unix.EINTR, _, _) -> openfile fn mode perm
-
-let fd_for_file flag f =
-  try Ok (openfile (Fpath.to_string f) (Unix.O_CLOEXEC :: flag) 0o644)
-  with Unix.Unix_error (e, _, _) -> err_file f e
-
-let read_fd_for_file = fd_for_file Unix.[ O_RDONLY ]
-
-let write_fd_for_file = fd_for_file Unix.[ O_WRONLY ; O_APPEND ]
-
-let null = match read_fd_for_file (Fpath.v "/dev/null") with
-  | Ok fd -> fd
-  | Error _ -> invalid_arg "cannot read /dev/null"
-
-let rec create_process prog args stdout stderr =
-  try Unix.create_process prog args null stdout stderr with
-  | Unix.Unix_error (Unix.EINTR, _, _) ->
-      create_process prog args stdout stderr
-
-let rec close fd =
-  try Unix.close fd with
-  | Unix.Unix_error (Unix.EINTR, _, _) -> close fd
-
-let close_no_err fd = try close fd with _ -> ()
-
-(* own code starts here
-   (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
 
+(* the wire protocol *)
 open Vmm_core
 
-let rec mkfifo name =
-  try Unix.mkfifo (Fpath.to_string name) 0o640 with
-  | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
+type version = [ `AV2 ]
 
-let image_file, fifo_file =
-  ((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")),
-   (fun vm -> Fpath.(tmpdir / (vm_id vm) + "fifo")))
+let pp_version ppf v =
+  Fmt.int ppf
+    (match v with
+     | `AV2 -> 2)
 
-let rec fifo_exists file =
-  try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
-  | Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
-  | Unix.Unix_error (Unix.EINTR, _, _) -> fifo_exists file
-  | Unix.Unix_error (e, _, _) ->
-      R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
+let version_eq a b =
+  match a, b with
+  | `AV2, `AV2 -> true
+  | _ -> false
 
-let uname () =
-  let cmd = Bos.Cmd.(v "uname" % "-s") in
-  lazy Bos.OS.Cmd.(run_out cmd |> out_string)
+type console_cmd = [
+  | `Console_add
+  | `Console_subscribe of Ptime.t option
+]
 
-let create_tap bridge =
-  Lazy.force (uname ()) >>= fun (sys, _) ->
-  match sys with
-  | x when x = "FreeBSD" ->
-    let cmd = Bos.Cmd.(v "ifconfig" % "tap" % "create") in
-    Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % bridge % "addm" % name) >>= fun () ->
-    Ok name
-  | x when x = "Linux" ->
-    let prefix = "vmmtap" in
-    let rec find_n x =
-      let nam = prefix ^ string_of_int x in
-      match Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % nam) with
-      | Error _ -> nam
-      | Ok _ -> find_n (succ x)
-    in
-    let tap = find_n 0 in
-    Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "add" % "mode" % "tap" % tap) >>= fun () ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addif" % bridge % tap) >>= fun () ->
-    Ok tap
-  | x -> Error (`Msg ("unsupported operating system " ^ x))
+let pp_console_cmd ppf = function
+  | `Console_add -> Fmt.string ppf "console add"
+  | `Console_subscribe ts ->
+    Fmt.pf ppf "console subscribe since %a"
+      Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
 
-let destroy_tap tapname =
-  Lazy.force (uname ()) >>= fun (sys, _) ->
-  match sys with
-  | x when x = "FreeBSD" ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % tapname % "destroy")
-  | x when x = "Linux" ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
-  | x -> Error (`Msg ("unsupported operating system " ^ x))
+type stats_cmd = [
+  | `Stats_add of int * string list
+  | `Stats_remove
+  | `Stats_subscribe
+]
 
-let create_bridge bname =
-  Lazy.force (uname ()) >>= fun (sys, _) ->
-  match sys with
-  | x when x = "FreeBSD" ->
-    let cmd = Bos.Cmd.(v "ifconfig" % "bridge" % "create") in
-    Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % name % "name" % bname)
-  | x when x = "Linux" ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addbr" % bname)
-  | x -> Error (`Msg ("unsupported operating system " ^ x))
+let pp_stats_cmd ppf = function
+  | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps
+  | `Stats_remove -> Fmt.string ppf "stat remove"
+  | `Stats_subscribe -> Fmt.string ppf "stat subscribe"
 
-let prepare vm =
-  (match vm.vmimage with
-   | `Ukvm_amd64, blob -> Ok blob
-   | `Ukvm_amd64_compressed, blob ->
-     begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
-       | Ok blob -> Ok (Cstruct.of_string blob)
-       | Error () -> Error (`Msg "failed to uncompress")
-     end
-   | `Ukvm_arm64, _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image ->
-  let fifo = fifo_file vm in
-  (match fifo_exists fifo with
-   | Ok true -> Ok ()
-   | Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
-   | Error _ ->
-     try Ok (mkfifo fifo) with
-     | Unix.Unix_error (e, f, _) ->
-       Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
-       Error (`Msg "while creating fifo")) >>= fun () ->
-  List.fold_left (fun acc b ->
-      acc >>= fun acc ->
-      create_tap b >>= fun tap ->
-      Ok (tap :: acc))
-    (Ok []) vm.network >>= fun taps ->
-  Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () ->
-  Ok (List.rev taps)
+type log_cmd = [
+  | `Log_subscribe of Ptime.t option
+]
 
-let shutdown vm =
-  (* same order as prepare! *)
-  Bos.OS.File.delete (image_file vm.config) >>= fun () ->
-  Bos.OS.File.delete (fifo_file vm.config) >>= fun () ->
-  List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
+let pp_log_cmd ppf = function
+  | `Log_subscribe ts ->
+    Fmt.pf ppf "log subscribe since %a"
+      Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
 
-let cpuset cpu =
-  Lazy.force (uname ()) >>= fun (sys, _) ->
-  let cpustring = string_of_int cpu in
-  match sys with
-  | x when x = "FreeBSD" ->
-    Ok ([ "cpuset" ; "-l" ; cpustring ])
-  | x when x = "Linux" ->
-    Ok ([ "taskset" ; "-c" ; cpustring ])
-  | x -> Error (`Msg ("unsupported operating system " ^ x))
+type vm_cmd = [
+  | `Vm_info
+  | `Vm_create of vm_config
+  | `Vm_force_create of vm_config
+  | `Vm_destroy
+]
 
-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.(dbdir / "ukvm-bin.none")
-   | [_] -> 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
-  let cmd =
-    Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
-             "--" % p (image_file vm) %% of_list argv)
-  in
-  let line = Bos.Cmd.to_list cmd in
-  let prog = try List.hd line with Failure _ -> failwith err_empty_line in
-  let line = Array.of_list line in
-  let fifo = fifo_file vm in
-  Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
-  write_fd_for_file fifo >>= fun stdout ->
-  Logs.debug (fun m -> m "opened file descriptor!");
-  try
-    Logs.debug (fun m -> m "creating process");
-    let pid = create_process prog line stdout stdout in
-    Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
-    (* this should get rid of the vmimage from vmmd's memory! *)
-    let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
-    Ok { config ; cmd ; pid ; taps ; stdout }
-  with
-    Unix.Unix_error (e, _, _) ->
-    close_no_err stdout;
-    R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
+let pp_vm_cmd ppf = function
+  | `Vm_info -> Fmt.string ppf "vm info"
+  | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
+  | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
+  | `Vm_destroy -> Fmt.string ppf "vm destroy"
+
+type policy_cmd = [
+  | `Policy_info
+  | `Policy_add of policy
+  | `Policy_remove
+]
+
+let pp_policy_cmd ppf = function
+  | `Policy_info -> Fmt.string ppf "policy info"
+  | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
+  | `Policy_remove -> Fmt.string ppf "policy remove"
+
+type t = [
+    | `Console_cmd of console_cmd
+    | `Stats_cmd of stats_cmd
+    | `Log_cmd of log_cmd
+    | `Vm_cmd of vm_cmd
+    | `Policy_cmd of policy_cmd
+  ]
+
+let pp ppf = function
+  | `Console_cmd c -> pp_console_cmd ppf c
+  | `Stats_cmd s -> pp_stats_cmd ppf s
+  | `Log_cmd l -> pp_log_cmd ppf l
+  | `Vm_cmd v -> pp_vm_cmd ppf v
+  | `Policy_cmd p -> pp_policy_cmd ppf p
+
+type data = [
+  | `Console_data of Ptime.t * string
+  | `Stats_data of Stats.t
+  | `Log_data of Log.t
+]
+
+let pp_data ppf = function
+  | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
+                                  (Ptime.pp_rfc3339 ()) ts line
+  | `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats
+  | `Log_data log -> Fmt.pf ppf "log data: %a" Log.pp log
+
+type header = {
+  version : version ;
+  sequence : int64 ;
+  id : id ;
+}
+
+type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
+
+let pp_success ppf = function
+  | `Empty -> Fmt.string ppf "success"
+  | `String data -> Fmt.pf ppf "success: %s" data
+  | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
+  | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
+
+type wire = header * [
+    | `Command of t
+    | `Success of success
+    | `Failure of string
+    | `Data of data ]
+
+let pp_wire ppf (header, data) =
+  let id = header.id in
+  match data with
+  | `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c
+  | `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
+  | `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
+  | `Data d -> pp_data ppf d
+
+let endpoint = function
+  | `Vm_cmd _ -> `Vmmd, `End
+  | `Policy_cmd _ -> `Vmmd, `End
+  | `Stats_cmd _ -> `Stats, `Read
+  | `Console_cmd _ -> `Console, `Read
+  | `Log_cmd _ -> `Log, `Read
 
-let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)

src/vmm_commands.mli

@@ -1,19 +1,80 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Rresult
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
 
 open Vmm_core
 
-val prepare : vm_config -> (string list, [> R.msg ]) result
+(** The type of versions of the grammar defined below. *)
+type version = [ `AV2 ]
 
-val shutdown : vm -> (unit, [> R.msg ]) result
+(** [version_eq a b] is true if [a] and [b] are equal. *)
+val version_eq : version -> version -> bool
 
-val exec : vm_config -> string list -> (vm, [> R.msg ]) result
+(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
+val pp_version : version Fmt.t
 
-val destroy : vm -> unit
+type console_cmd = [
+  | `Console_add
+  | `Console_subscribe of Ptime.t option
+]
 
-val close_no_err : Unix.file_descr -> unit
+type stats_cmd = [
+  | `Stats_add of int * string list
+  | `Stats_remove
+  | `Stats_subscribe
+]
 
-val create_tap : string -> (string, [> R.msg ]) result
+type log_cmd = [
+  | `Log_subscribe of Ptime.t option
+]
 
-val create_bridge : string -> (unit, [> R.msg ]) result
+type vm_cmd = [
+  | `Vm_info
+  | `Vm_create of vm_config
+  | `Vm_force_create of vm_config
+  | `Vm_destroy
+]
+
+type policy_cmd = [
+  | `Policy_info
+  | `Policy_add of policy
+  | `Policy_remove
+]
+
+type t = [
+  | `Console_cmd of console_cmd
+  | `Stats_cmd of stats_cmd
+  | `Log_cmd of log_cmd
+  | `Vm_cmd of vm_cmd
+  | `Policy_cmd of policy_cmd ]
+
+val pp : t Fmt.t
+
+type data = [
+  | `Console_data of Ptime.t * string
+  | `Stats_data of Stats.t
+  | `Log_data of Log.t
+]
+
+val pp_data : data Fmt.t
+
+type header = {
+  version : version ;
+  sequence : int64 ;
+  id : id ;
+}
+
+type success = [
+  | `Empty
+  | `String of string
+  | `Policies of (id * policy) list
+  | `Vms of (id * vm_config) list
+]
+
+type wire = header * [
+    | `Command of t
+    | `Success of success
+    | `Failure of string
+    | `Data of data ]
+
+val pp_wire : wire Fmt.t
+
+val endpoint : t -> service * [ `End | `Read ]

src/vmm_compress.mli

@@ -0,0 +1,4 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+val compress : ?level:int -> string -> string
+val uncompress : string -> (string, unit) result

src/vmm_core.ml

@@ -7,6 +7,23 @@ open Rresult.R.Infix
 let tmpdir = Fpath.(v "/var" / "run" / "albatross")
 let dbdir = Fpath.(v "/var" / "db" / "albatross")
 
+type service = [ `Console | `Log | `Stats | `Vmmd ]
+
+let socket_path t =
+  let path name = Fpath.(tmpdir / "util" / name + "sock") in
+  let path = match t with
+    | `Console -> path "console"
+    | `Vmmd -> Fpath.(tmpdir / "vmmd" + "sock")
+    | `Stats -> path "stat"
+    | `Log -> path "log"
+  in
+  Fpath.to_string path
+
+let pp_socket ppf t =
+  let name = socket_path t in
+  Fmt.pf ppf "socket: %s" name
+
+
 module I = struct
   type t = int
   let compare : int -> int -> int = compare
@@ -15,83 +32,12 @@ end
 module IS = Set.Make(I)
 module IM = Map.Make(I)
 
-type permission =
-  [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create]
-
-let pp_permission ppf = function
-  | `All -> Fmt.pf ppf "all"
-  | `Info -> Fmt.pf ppf "info"
-  | `Create -> Fmt.pf ppf "create"
-  | `Block -> Fmt.pf ppf "block"
-  | `Statistics -> Fmt.pf ppf "statistics"
-  | `Console -> Fmt.pf ppf "console"
-  | `Log -> Fmt.pf ppf "log"
-  | `Crl -> Fmt.pf ppf "crl"
-  | `Force_create -> Fmt.pf ppf "force-create"
-
-let permission_of_string = function
-  | x when x = "all" -> Some `All
-  | x when x = "info" -> Some `Info
-  | x when x = "create" -> Some `Create
-  | x when x = "block" -> Some `Block
-  | x when x = "statistics" -> Some `Statistics
-  | x when x = "console" -> Some `Console
-  | x when x = "log" -> Some `Log
-  | x when x = "crl" -> Some `Crl
-  | x when x = "force-create" -> Some `Force_create
-  | _ -> None
-
-type cmd =
-  | Info
-  | Destroy_vm
-  | Create_block
-  | Destroy_block
-  | Statistics
-  | Attach
-  | Detach
-  | Log
-
-let pp_cmd ppf = function
-  | Info -> Fmt.pf ppf "info"
-  | Destroy_vm -> Fmt.pf ppf "destroy"
-  | Create_block -> Fmt.pf ppf "create-block"
-  | Destroy_block -> Fmt.pf ppf "destroy-block"
-  | Statistics -> Fmt.pf ppf "statistics"
-  | Attach -> Fmt.pf ppf "attach"
-  | Detach -> Fmt.pf ppf "detach"
-  | Log -> Fmt.pf ppf "log"
-
-let cmd_of_string = function
-  | x when x = "info" -> Some Info
-  | x when x = "destroy" -> Some Destroy_vm
-  | x when x = "create-block" -> Some Create_block
-  | x when x = "destroy-block" -> Some Destroy_block
-  | x when x = "statistics" -> Some Statistics
-  | x when x = "attach" -> Some Attach
-  | x when x = "detach" -> Some Detach
-  | x when x = "log" -> Some Log
-  | _ -> None
-
-let cmd_allowed permissions cmd =
-  List.mem `All permissions ||
-  let perm = match cmd with
-    | Info -> `Info
-    | Destroy_vm -> `Create
-    | Create_block -> `Block
-    | Destroy_block -> `Block
-    | Statistics -> `Statistics
-    | Attach -> `Console
-    | Detach -> `Console
-    | Log -> `Log
-  in
-  List.mem perm permissions
-
-type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ]
+type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
 
 let pp_vmtype ppf = function
-  | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64"
-  | `Ukvm_amd64_compressed -> Fmt.pf ppf "ukvm-amd64-compressed"
-  | `Ukvm_arm64 -> Fmt.pf ppf "ukvm-arm64"
+  | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
+  | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
+  | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
 
 type id = string list
 
@@ -110,8 +56,12 @@ let drop_super ~super ~sub =
 let is_sub_id ~super ~sub =
   match drop_super ~super ~sub with None -> false | Some _ -> true
 
+let domain id = match List.rev id with
+  | _::prefix -> List.rev prefix
+  | [] -> []
+
 let pp_id ppf ids =
-  Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids)
+  Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
 
 let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
 
@@ -120,13 +70,27 @@ type bridge = [
   | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
 ]
 
+let eq_int (a : int) (b : int) = a = b
+
+let eq_bridge b1 b2 = match b1, b2 with
+  | `Internal a, `Internal a' -> String.equal a a'
+  | `External (name, ip_start, ip_end, ip_gw, netmask),
+    `External (name', ip_start', ip_end', ip_gw', netmask') ->
+    let eq_ip a b = Ipaddr.V4.compare a b = 0 in
+    String.equal name name' &&
+    eq_ip ip_start ip_start' &&
+    eq_ip ip_end ip_end' &&
+    eq_ip ip_gw ip_gw' &&
+    eq_int netmask netmask'
+  | _ -> false
+
 let pp_bridge ppf = function
   | `Internal name -> Fmt.pf ppf "%s (internal)" name
   | `External (name, l, h, gw, nm) ->
     Fmt.pf ppf "%s: %a - %a, GW: %a/%d"
       name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm
 
-type delegation = {
+type policy = {
   vms : int ;
   cpuids : IS.t ;
   memory : int ;
@@ -134,8 +98,20 @@ type delegation = {
   bridges : bridge String.Map.t ;
 }
 
-let pp_delegation ppf res =
-  Fmt.pf ppf "delegated: %d vms %a cpus %d MB memory %a MB block bridges: %a"
+let eq_policy p1 p2 =
+  let eq_opt a b = match a, b with
+    | None, None -> true
+    | Some a, Some b -> eq_int a b
+    | _ -> false
+  in
+  eq_int p1.vms p2.vms &&
+  IS.equal p1.cpuids p2.cpuids &&
+  eq_int p1.memory p2.memory &&
+  eq_opt p1.block p2.block &&
+  String.Map.equal eq_bridge p1.bridges p2.bridges
+
+let pp_policy ppf res =
+  Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a"
     res.vms pp_is res.cpuids res.memory
     Fmt.(option ~none:(unit "no") int) res.block
     Fmt.(list ~sep:(unit ", ") pp_bridge)
@@ -169,8 +145,6 @@ let is_sub ~super ~sub =
   sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
 
 type vm_config = {
-  prefix : id ;
-  vname : string ;
   cpuid : int ;
   requested_memory : int ;
   block_device : string option ;
@@ -179,22 +153,13 @@ type vm_config = {
   argv : string list option ;
 }
 
-let fullname vm = vm.prefix @ [ vm.vname ]
-
-let vm_id vm = string_of_id (fullname vm)
-
-(* used for block devices *)
-let location vm = match vm.prefix with
-  | tld::rest -> tld, String.concat ~sep:"." (rest@[vm.vname])
-  | [] -> invalid_arg "dunno how this happened"
-
 let pp_image ppf (typ, blob) =
   let l = Cstruct.len blob in
   Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l
 
 let pp_vm_config ppf (vm : vm_config) =
-  Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
-    vm.vname vm.cpuid vm.requested_memory
+  Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
+    vm.cpuid vm.requested_memory
     Fmt.(option ~none:(unit "no") string) vm.block_device
     Fmt.(list ~sep:(unit ", ") string) vm.network
     pp_image vm.vmimage
@@ -204,7 +169,7 @@ let good_bridge idxs nets =
   (* TODO: uniqueness of n -- it should be an ordered set? *)
   List.for_all (fun n -> String.Map.mem n nets) idxs
 
-let vm_matches_res (res : delegation) (vm : vm_config)  =
+let vm_matches_res (res : policy) (vm : vm_config)  =
   res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
   vm.requested_memory <= res.memory &&
   good_bridge vm.network res.bridges
@@ -238,51 +203,7 @@ let translate_tap vm tap =
   | [ (_, b) ] -> Some b
   | _ -> None
 
-let identifier serial =
-  match Hex.of_cstruct @@ Nocrypto.Hash.SHA256.digest @@
-    Nocrypto.Numeric.Z.to_cstruct_be @@ serial
-  with
-  | `Hex str -> fst (String.span ~max:6 str)
-
-let id cert = identifier (X509.serial cert)
-
-let parse_db lines =
-  List.fold_left (fun acc s ->
-      acc >>= fun datas ->
-      match String.cut ~sep:" " s with
-      | None -> Rresult.R.error_msgf "unable to parse entry %s" s
-      | Some (a, b) ->
-        (try Ok (Z.of_string a) with Invalid_argument x -> Error (`Msg x)) >>= fun s ->
-        Ok ((s, b) :: datas))
-    (Ok []) lines
-
-let find_in_db label db tst =
-  try Ok (List.find tst db)
-  with Not_found -> Rresult.R.error_msgf "couldn't find %s in database" label
-
-let find_name db name =
-  find_in_db name db (fun (_, n) -> String.equal n name) >>= fun (serial, _) ->
-  Ok serial
-
-let translate_serial db serial =
-  let tst (s, _) = String.equal serial (identifier s) in
-  match find_in_db "" db tst with
-  | Ok (_, n) -> n
-  | Error _ -> serial
-
-let translate_name db name =
-  match find_name db name with
-  | Ok serial -> identifier serial
-  | Error _ -> name
-
-(* this separates the leaf and top-level certificate from the chain,
-   and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
-   in which subCA' signed leaf *)
-let separate_chain = function
-  | [] -> Error (`Msg "empty chain")
-  | [ leaf ] -> Ok (leaf, [])
-  | leaf :: xs -> Ok (leaf, List.rev xs)
-
+module Stats = struct
   type rusage = {
     utime : (int64 * int) ;
     stime : (int64 * int) ;
@@ -306,6 +227,11 @@ let pp_rusage ppf r =
     Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
       (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw
 
+
+  type vmm = (string * int64) list
+  let pp_vmm ppf vmm =
+    Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm
+
   type ifdata = {
     name : string ;
     flags : int32 ;
@@ -331,57 +257,50 @@ let pp_ifdata ppf i =
     Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
       i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
 
+  type t = rusage * vmm option * ifdata list
+  let pp ppf (ru, vmm, ifs) =
+    Fmt.pf ppf "%a@.%a@.%a"
+      pp_rusage ru
+      Fmt.(option ~none:(unit "no vmm stats") pp_vmm) vmm
+      Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs
+end
+
+type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
+
+let pp_process_exit ppf = function
+  | `Exit n -> Fmt.pf ppf "exit %a (%d)" Fmt.Dump.signal n n
+  | `Signal n -> Fmt.pf ppf "signal %a (%d)" Fmt.Dump.signal n n
+  | `Stop n -> Fmt.pf ppf "stop %a (%d)" Fmt.Dump.signal n n
+
 module Log = struct
-  type hdr = {
-    ts : Ptime.t ;
-    context : id ;
-    name : string ;
-  }
-
-  let pp_hdr db ppf (hdr : hdr) =
-    let name = translate_serial db hdr.name in
-    Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name
-
-  let hdr context name = { ts = Ptime_clock.now () ; context ; name }
-
-  type event =
-    [ `Startup
-    | `Login of Ipaddr.V4.t * int
-    | `Logout of Ipaddr.V4.t * int
-    | `VM_start of int * string list * string option
-    | `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ]
-    | `Block_create of string * int
-    | `Block_destroy of string
-    | `Delegate of string list * string option
-      (* | `CRL of string *)
+  type log_event = [
+    | `Login of id * Ipaddr.V4.t * int
+    | `Logout of id * Ipaddr.V4.t * int
+    | `Startup
+    | `Vm_start of id * int * string list * string option
+    | `Vm_stop of id * int * process_exit
   ]
 
-  let pp_event ppf = function
-    | `Startup -> Fmt.(pf ppf "STARTUP")
-    | `Login (ip, port) -> Fmt.pf ppf "LOGIN %a:%d" Ipaddr.V4.pp_hum ip port
-    | `Logout (ip, port) -> Fmt.pf ppf "LOGOUT %a:%d" Ipaddr.V4.pp_hum ip port
-    | `VM_start (pid, taps, block) ->
-      Fmt.pf ppf "STARTED %d (tap %a, block %a)"
-        pid Fmt.(list ~sep:(unit "; ") string) taps
-        Fmt.(option ~none:(unit "no") string) block
-    | `VM_stop (pid, code) ->
-      let s, c = match code with
-        | `Exit n -> "exit", n
-        | `Signal n -> "signal", n
-        | `Stop n -> "stop", n
-      in
-      Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c
-    | `Block_create (name, size) ->
-      Fmt.pf ppf "BLOCK_CREATE %s %d" name size
-    | `Block_destroy name -> Fmt.pf ppf "BLOCK_DESTROY %s" name
-    | `Delegate (bridges, block) ->
-      Fmt.pf ppf "DELEGATE %a, block %a"
-        Fmt.(list ~sep:(unit "; ") string) bridges
-        Fmt.(option ~none:(unit "no") string) block
-      (* | `CRL of string *)
+  let name = function
+    | `Startup -> []
+    | `Login (name, _, _) -> name
+    | `Logout (name, _, _) -> name
+    | `Vm_start (name, _, _ ,_) -> name
+    | `Vm_stop (name, _, _) -> name
 
-  type msg = hdr * event
+  let pp_log_event ppf = function
+    | `Startup -> Fmt.(pf ppf "startup")
+    | `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
+    | `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
+    | `Vm_start (name, pid, taps, block) ->
+      Fmt.pf ppf "%a started %d (tap %a, block %a)"
+        pp_id name pid Fmt.(list ~sep:(unit "; ") string) taps
+        Fmt.(option ~none:(unit "no") string) block
+    | `Vm_stop (name, pid, code) ->
+      Fmt.pf ppf "%a stopped %d with %a" pp_id name pid pp_process_exit code
 
-  let pp db ppf (hdr, event) =
-    Fmt.pf ppf "%a %a" (pp_hdr db) hdr pp_event event
+  type t = Ptime.t * log_event
+
+  let pp ppf (ts, ev) =
+    Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) ts pp_log_event ev
 end

src/vmm_core.mli

@@ -0,0 +1,158 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+val tmpdir : Fpath.t
+val dbdir : Fpath.t
+
+type service = [ `Console | `Log | `Stats | `Vmmd ]
+
+val socket_path : service -> string
+val pp_socket : service Fmt.t
+
+module I : sig type t = int val compare : int -> int -> int end
+
+module IS : sig
+  include Set.S with type elt = I.t
+end
+val pp_is : IS.t Fmt.t
+
+module IM : sig
+  include Map.S with type key = I.t
+end
+
+type id = string list
+val string_of_id : string list -> string
+val id_of_string : string -> string list
+val drop_super : super:string list -> sub:string list -> string list option
+val is_sub_id : super:string list -> sub:string list -> bool
+val domain : 'a list -> 'a list
+val pp_id : id Fmt.t
+
+type bridge =
+  [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
+  | `Internal of string ]
+
+val eq_bridge : bridge -> bridge -> bool
+
+val pp_bridge : bridge Fmt.t
+
+type policy = {
+  vms : int;
+  cpuids : IS.t;
+  memory : int;
+  block : int option;
+  bridges : bridge Astring.String.Map.t;
+}
+
+val eq_policy : policy -> policy -> bool
+
+val pp_policy : policy Fmt.t
+
+val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool
+
+val sub_block : 'a option -> 'a option -> bool
+val sub_cpu : IS.t -> IS.t -> bool
+val is_sub : super:policy -> sub:policy -> bool
+
+type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
+val pp_vmtype : vmtype Fmt.t
+
+type vm_config = {
+  cpuid : int;
+  requested_memory : int;
+  block_device : string option;
+  network : string list;
+  vmimage : vmtype * Cstruct.t;
+  argv : string list option;
+}
+
+val pp_image : (vmtype * Cstruct.t) Fmt.t
+
+val pp_vm_config : vm_config Fmt.t
+val good_bridge : id -> 'a Astring.String.map -> bool
+
+val vm_matches_res : policy -> vm_config -> bool
+
+val check_policies :
+  vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result
+
+type vm = {
+  config : vm_config;
+  cmd : Bos.Cmd.t;
+  pid : int;
+  taps : string list;
+  stdout : Unix.file_descr;
+}
+
+val pp_vm : vm Fmt.t
+val translate_tap : vm -> string -> string option
+
+module Stats : sig
+  type rusage = {
+    utime : int64 * int;
+    stime : int64 * int;
+    maxrss : int64;
+    ixrss : int64;
+    idrss : int64;
+    isrss : int64;
+    minflt : int64;
+    majflt : int64;
+    nswap : int64;
+    inblock : int64;
+    outblock : int64;
+    msgsnd : int64;
+    msgrcv : int64;
+    nsignals : int64;
+    nvcsw : int64;
+    nivcsw : int64;
+  }
+  val pp_rusage : rusage Fmt.t
+
+  type vmm = (string * int64) list
+  val pp_vmm : vmm Fmt.t
+
+  type ifdata = {
+    name : string;
+    flags : int32;
+    send_length : int32;
+    max_send_length : int32;
+    send_drops : int32;
+    mtu : int32;
+    baudrate : int64;
+    input_packets : int64;
+    input_errors : int64;
+    output_packets : int64;
+    output_errors : int64;
+    collisions : int64;
+    input_bytes : int64;
+    output_bytes : int64;
+    input_mcast : int64;
+    output_mcast : int64;
+    input_dropped : int64;
+    output_dropped : int64;
+  }
+  val pp_ifdata : ifdata Fmt.t
+
+  type t = rusage * vmm option * ifdata list
+  val pp : t Fmt.t
+end
+
+type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
+
+val pp_process_exit : process_exit Fmt.t
+
+module Log : sig
+  type log_event = [
+    | `Login of id * Ipaddr.V4.t * int
+    | `Logout of id * Ipaddr.V4.t * int
+    | `Startup
+    | `Vm_start of id * int * string list * string option
+    | `Vm_stop of id * int * process_exit ]
+
+  val name : log_event -> id
+
+  val pp_log_event : log_event Fmt.t
+
+  type t = Ptime.t * log_event
+
+  val pp : t Fmt.t
+end

src/vmm_engine.ml

@@ -1,550 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Astring
-
-open Vmm_core
-
-open Rresult
-open R.Infix
-
-type ('a, 'b, 'c) t = {
-  cmp : 'b -> 'b -> bool ;
-  console_socket : 'a ;
-  console_counter : int ;
-  console_requests : (('a, 'b, 'c) t -> ('a, 'b, 'c) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ;
-  console_attached : 'b String.Map.t ; (* vm_name -> socket *)
-  console_version : Vmm_wire.version ;
-  stats_socket : 'a option ;
-  stats_counter : int ;
-  stats_requests : ('b * int * (string -> string option)) IM.t ;
-  stats_version : Vmm_wire.version ;
-  log_socket : 'a ;
-  log_counter : int ;
-  log_requests : ('b * int) IM.t ;
-  log_attached : ('b * string) list String.Map.t ;
-  log_version : Vmm_wire.version ;
-  client_version : Vmm_wire.version ;
-  (* TODO: refine, maybe:
-     bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *)
-  used_bridges : String.Set.t String.Map.t ;
-  (* TODO: used block devices (since each may only be active once) *)
-  resources : Vmm_resources.t ;
-  tasks : 'c String.Map.t ;
-  crls : X509.CRL.c list ;
-}
-
-let init cmp console_socket stats_socket log_socket =
-  (* error hard on permission denied etc. *)
-  let crls = Fpath.(dbdir / "crls") in
-  (Bos.OS.Dir.exists crls >>= function
-    | true -> Ok true
-    | false -> Bos.OS.Dir.create crls) >>= fun _ ->
-  let err _ x = x in
-  Bos.OS.Dir.fold_contents ~elements:`Files ~traverse:`None ~err
-    (fun f acc ->
-       acc >>= fun acc ->
-       Bos.OS.File.read f >>= fun data ->
-       match X509.Encoding.crl_of_cstruct (Cstruct.of_string data) with
-       | None -> R.error_msgf "couldn't parse CRL %a" Fpath.pp f
-       | Some crl -> Ok (crl :: acc))
-    (Ok [])
-    crls >>= fun crls ->
-  crls >>= fun crls ->
-  Ok {
-    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 = `WV1 ;
-    log_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
-    log_version = `WV0 ; log_requests = IM.empty ;
-    client_version = `WV0 ;
-    used_bridges = String.Map.empty ;
-    resources = Vmm_resources.empty ;
-    tasks = String.Map.empty ;
-    crls
-  }
-
-let asn_version = `AV0
-
-let log state (hdr, event) =
-  let pre = string_of_id hdr.Log.context in
-  let out = match String.Map.find pre state.log_attached with
-    | None -> []
-    | Some x -> x
-  in
-  let data = Vmm_wire.Log.data state.log_counter state.log_version hdr event in
-  let tls = Vmm_wire.Client.log hdr event state.client_version in
-  let log_counter = succ state.log_counter in
-  Logs.debug (fun m -> m "LOG %a" (Log.pp []) (hdr, event)) ;
-  ({ state with log_counter },
-   `Raw (state.log_socket, data) :: List.map (fun (s, _) -> `Tls (s, tls)) out)
-
-let stat state str =
-  match state.stats_socket with
-  | None -> []
-  | Some s -> [ `Raw (s, str) ]
-
-let handle_disconnect state t =
-  Logs.err (fun m -> m "disconnect!!") ;
-  let rem, console_attached =
-    String.Map.partition (fun _ s -> state.cmp s t) state.console_attached
-  in
-  let out, console_counter =
-    List.fold_left (fun (acc, ctr) name ->
-        (acc ^ Vmm_wire.Console.detach ctr state.console_version name, succ ctr))
-      ("", state.console_counter)
-      (fst (List.split (String.Map.bindings rem)))
-  in
-  let log_attached = String.Map.fold (fun k v n ->
-      match List.filter (fun (e, _) -> not (state.cmp t e)) v with
-      | [] -> n
-      | xs -> String.Map.add k xs n)
-      state.log_attached String.Map.empty
-  in
-  let out =
-    if String.length out = 0 then
-      []
-    else
-      [ (state.console_socket, out) ]
-  in
-  { state with console_attached ; console_counter ; log_attached }, out
-
-let handle_create t vm_config policies =
-  let full = fullname vm_config in
-  (if Vmm_resources.exists t.resources full then
-     Error (`Msg "VM with same name is already running")
-   else
-     Ok ()) >>= fun () ->
-  Logs.debug (fun m -> m "now checking dynamic policies") ;
-  Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () ->
-  (* prepare VM: save VM image to disk, create fifo, ... *)
-  Vmm_commands.prepare vm_config >>= fun taps ->
-  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 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 =
-          List.fold_left2 (fun b br ta ->
-              let old = match String.Map.find br b with
-                | None -> String.Set.empty
-                | Some x -> x
-              in
-              String.Map.add br (String.Set.add ta old) b)
-            t.used_bridges vm_config.network taps
-        in
-        let t = { t with resources ; used_bridges } in
-        let t, out = log t (Log.hdr vm_config.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) :: out, vm))
-
-let setup_stats t vm =
-  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)
-
-let handle_shutdown t vm r =
-  (match Vmm_commands.shutdown vm with
-   | Ok () -> ()
-   | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
-  let resources =
-    match Vmm_resources.remove t.resources (fullname vm.config) vm with
-    | Ok resources -> resources
-    | Error (`Msg e) ->
-      Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ;
-      t.resources
-  in
-  let used_bridges =
-    List.fold_left2 (fun b br ta ->
-        let old = match String.Map.find br b with
-          | None -> String.Set.empty
-          | Some x -> x
-        in
-        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_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,
-                       `VM_stop (vm.pid, r))
-  in
-  (t, stat t stat_out @ outs)
-
-let handle_command t s prefix perms hdr buf =
-  let res =
-    if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
-      Error (`Msg "unknown client version")
-    else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
-      | None -> Error (`Msg "unknown command")
-      | Some x when cmd_allowed perms x ->
-        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
-              | None ->
-                Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
-                R.error_msgf "info: %s not found" buf
-              | Some x ->
-                let data =
-                  Vmm_resources.fold (fun acc vm ->
-                      acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm)
-                    "" x
-                in
-                let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
-                Ok (t, [ `Tls (s, out) ])
-            end
-          | Destroy_vm ->
-            begin match Vmm_resources.find_vm t.resources arg with
-              | Some vm ->
-                Vmm_commands.destroy vm ;
-                let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
-                Ok (t, [ `Tls (s, out) ])
-              | _ ->
-                Error (`Msg ("destroy: not found " ^ buf))
-            end
-          | Attach ->
-            (* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
-            let on_success t =
-              let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
-              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 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 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 cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
-            (match String.Map.find vmid t.console_attached with
-             | None -> Error (`Msg "not 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 },
-                [ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
-          | Statistics ->
-            begin match t.stats_socket with
-              | 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 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 },
-                      stat t stat_out)
-                | _ -> Error (`Msg ("statistics: not found " ^ buf))
-            end
-          | Log ->
-            begin
-              let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
-              let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
-              let log_counter = succ t.log_counter in
-              Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
-            end
-          | Create_block | Destroy_block -> Error (`Msg "NYI")
-        end
-      | Some _ -> Error (`Msg "unauthorised command")
-  in
-  match res with
-  | Ok r -> r
-  | Error (`Msg msg) ->
-    Logs.debug (fun m -> m "error while processing command: %s" msg) ;
-    let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in
-    (t, [ `Tls (s, out) ])
-
-let handle_single_revocation t prefix serial =
-  let id = identifier serial in
-  (match Vmm_resources.find t.resources (prefix @ [ id ]) with
-   | None -> ()
-   | Some e -> Vmm_resources.iter Vmm_commands.destroy e) ;
-  (* also revoke all active sessions!? *)
-  (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
-  let log_attached, kill =
-    let pid = string_of_id prefix in
-    match String.Map.find pid t.log_attached with
-    | None -> t.log_attached, []
-    | Some xs ->
-      (* those where snd v = serial: drop *)
-      let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
-      String.Map.add pid keep t.log_attached, drop
-  in
-  (* two things:
-     1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
-     2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *)
-  let log_attached, kill =
-    String.Map.fold (fun k' v (l, k) ->
-        if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then
-          (l, v @ k)
-        else
-          (String.Map.add k' v l, k))
-      log_attached
-      (String.Map.empty, kill)
-  in
-  let state, out =
-    List.fold_left (fun (s, out) (t, _) ->
-        let s', out' = handle_disconnect s t in
-        s', out @ out')
-      ({ t with log_attached }, [])
-      kill
-  in
-  (state,
-   List.map (fun x -> `Raw x) out,
-   List.map fst kill)
-
-let handle_revocation t s leaf chain ca prefix =
-  Vmm_asn.crl_of_cert leaf >>= fun crl ->
-  (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
-  let issuer = match chain with
-    | subca::_ -> subca
-    | [] -> ca
-  in
-  let time = Ptime_clock.now () in
-  (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () ->
-  (* the this_update must be > now, next_update < now, this_update > <local>.this_update, number > <local>.number *)
-  (* TODO: can we have something better for uniqueness of CRL? *)
-  let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in
-  (match local with
-   | None -> Ok ()
-   | Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with
-     | None, _ -> Ok ()
-     | 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.(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 *)
-  let crls =
-    match local with
-    | None -> crl :: t.crls
-    | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls
-  in
-  (* iterate over revoked serials, find active resources, and kill them *)
-  let newly_revoked =
-    let old = match local with
-      | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x)
-      | None -> []
-    in
-    let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in
-    List.filter (fun n -> not (List.mem n old)) new_rev
-  in
-  let t, out, close =
-    List.fold_left (fun (t, out, close) serial ->
-        let t', out', close' = handle_single_revocation t prefix serial in
-        (t', out @ out', close @ close'))
-      (t, [], []) newly_revoked
-  in
-  let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
-  Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
-
-let handle_initial t s addr chain ca =
-  separate_chain chain >>= fun (leaf, chain) ->
-  Logs.debug (fun m -> m "leaf is %s, chain %a"
-                 (X509.common_name_to_string leaf)
-                 Fmt.(list ~sep:(unit "->") string)
-                 (List.map X509.common_name_to_string chain)) ;
-  (* TODO here: inspect top-level-cert of chain.
-     may need to create bridges and/or block device subdirectory (zfs create) *)
-  let prefix = List.map id chain in
-  let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
-  let t, out = log t (login_hdr, login_ev) in
-  let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
-  Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
-  (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
-     (* convert certificate to vm_config *)
-     Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
-     Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
-     (* get names and static resources *)
-     List.fold_left (fun acc ca ->
-         acc >>= fun acc ->
-         Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
-         let name = id ca in
-         Ok ((name, res) :: acc))
-       (Ok []) chain >>= fun policies ->
-     (* check static policies *)
-     Logs.debug (fun m -> m "now checking static policies") ;
-     check_policies vm_config (List.map snd policies) >>= fun () ->
-     let t, task =
-       let force = List.mem `Force_create perms in
-       if force then
-         let fid = vm_id vm_config in
-         match String.Map.find fid t.tasks with
-         | None -> t, None
-         | Some task ->
-           let kill () =
-             match Vmm_resources.find_vm t.resources (fullname vm_config) with
-             | None ->
-               Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
-                            pp_id (fullname vm_config) fid)
-             | Some vm ->
-               Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
-               Vmm_commands.destroy vm
-           in
-           let tasks = String.Map.remove fid t.tasks in
-           ({ t with tasks }, Some (kill, task))
-       else
-         t, None
-     in
-     let next t sleeper =
-       handle_create t vm_config policies >>= fun cont ->
-       let id = vm_id vm_config in
-       let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
-       let tasks = String.Map.add id sleeper t.tasks in
-       Ok ({ t with console_counter = succ t.console_counter ; tasks },
-           [ `Raw (t.console_socket, cons) ],
-           cont)
-     in
-     Ok (t, [], `Create (task, next))
-   else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
-     handle_revocation t s leaf chain ca prefix
-   else
-     let log_attached =
-       if cmd_allowed perms Log then
-         let pre = string_of_id prefix in
-         let v = match String.Map.find pre t.log_attached with
-           | None -> []
-           | Some xs -> xs
-         in
-         String.Map.add pre ((s, id leaf) :: v) t.log_attached
-       else
-         t.log_attached
-     in
-     Ok ({ t with log_attached }, [], `Loop (prefix, perms))
-  ) >>= fun (t, outs, res) ->
-  Ok (t, initial_out :: out @ outs, res)
-
-let handle_stat state hdr data =
-  let open Vmm_wire in
-  if not (version_eq hdr.version state.stats_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
-    state, []
-  end else if hdr.tag = success_tag then
-    state, []
-  else
-    match IM.find hdr.id state.stats_requests with
-    | exception Not_found ->
-      Logs.err (fun m -> m "couldn't find stat request") ;
-      state, []
-    | (s, req_id, f) ->
-      let stats_requests = IM.remove hdr.id state.stats_requests in
-      let state = { state with stats_requests } in
-      let out =
-        match Stats.int_to_op hdr.tag with
-        | Some Stats.Stat_reply ->
-          begin match Stats.decode_stats (Cstruct.of_string data) with
-            | Ok (ru, vmm, ifs) ->
-              let ifs =
-                List.map
-                  (fun x ->
-                     match f x.name with
-                     | Some name -> { x with name }
-                     | None -> x)
-                  ifs
-              in
-              let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in
-              let out = Client.stat data req_id state.client_version in
-              [ `Tls (s, out) ]
-            | Error (`Msg msg) ->
-              Logs.err (fun m -> m "error %s while decode statistics" msg) ;
-              let out = fail req_id state.client_version in
-              [ `Tls (s, out) ]
-          end
-        | None when hdr.tag = fail_tag ->
-          let out = fail ~msg:data req_id state.client_version in
-          [ `Tls (s, out) ]
-        | _ ->
-          Logs.err (fun m -> m "unexpected reply from stat") ;
-          []
-      in
-      (state, out)
-
-let handle_cons state hdr data =
-  let open Vmm_wire in
-  if not (version_eq hdr.version state.console_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown console version") ;
-    state, []
-  end else match Console.int_to_op hdr.tag with
-    | Some Console.Data ->
-      begin match decode_str data with
-        | Error (`Msg msg) ->
-          Logs.err (fun m -> m "error while decoding console message %s" msg) ;
-          (state, [])
-        | Ok (file, off) ->
-        (match String.Map.find file state.console_attached with
-         | Some s ->
-           let out = Client.console off file data state.client_version in
-           (state, [ `Tls (s, out) ])
-         | None ->
-           (* TODO: should detach? *)
-           Logs.err (fun m -> m "couldn't find attached console for %s" file) ;
-           (state, []))
-    end
-  | None when hdr.tag = success_tag ->
-    (match IM.find hdr.id state.console_requests with
-     | exception Not_found ->
-       (state, [])
-     | cont ->
-       let state', outs = cont state in
-       let console_requests = IM.remove hdr.id state.console_requests in
-       ({ state' with console_requests }, outs))
-  | None when hdr.tag = fail_tag ->
-    (match IM.find hdr.id state.console_requests with
-     | exception Not_found ->
-       Logs.err (fun m -> m "fail couldn't find request id") ;
-       (state, [])
-     | _ ->
-       Logs.err (fun m -> m "failed while trying to do something on console") ;
-       let console_requests = IM.remove hdr.id state.console_requests in
-       ({ state with console_requests }, []))
-  | _ ->
-    Logs.err (fun m -> m "unexpected message received from console socket") ;
-    (state, [])
-
-let handle_log state hdr buf =
-  let open Vmm_wire in
-  let open Vmm_wire.Log in
-  if not (version_eq hdr.version state.log_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
-    state, []
-  end else match IM.find hdr.id state.log_requests with
-    | exception Not_found ->
-      Logs.warn (fun m -> m "(ignored) coudn't find log request") ;
-      (state, [])
-    | (s, rid) ->
-      let r = match int_to_op hdr.tag with
-        | Some Data ->
-          decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) ->
-          decode_event rest >>= fun event ->
-          let tls = Vmm_wire.Client.log hdr event state.client_version in
-          Ok (state, [ `Tls (s, tls) ])
-        | None when hdr.tag = success_tag ->
-          let log_requests = IM.remove hdr.id state.log_requests in
-          let tls = Vmm_wire.success rid state.client_version in
-          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
-        | None when hdr.tag = fail_tag ->
-          let log_requests = IM.remove hdr.id state.log_requests in
-          let tls = Vmm_wire.fail rid state.client_version in
-          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
-        | _ ->
-          Logs.err (fun m -> m "couldn't parse log reply") ;
-          let log_requests = IM.remove hdr.id state.log_requests in
-          Ok ({ state with log_requests }, [])
-      in
-      match r with
-      | Ok (s, out) -> s, out
-      | Error (`Msg msg) ->
-        Logs.err (fun m -> m "error while processing log %s" msg) ;
-        state, []

src/vmm_lwt.ml

@@ -2,6 +2,11 @@
 
 open Lwt.Infix
 
+let pp_sockaddr ppf = function
+  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+                                         (Unix.string_of_inet_addr addr) port
+
 let pp_process_status ppf = function
   | Unix.WEXITED c -> Fmt.pf ppf "exited with %d" c
   | Unix.WSIGNALED s -> Fmt.pf ppf "killed by signal %a" Fmt.Dump.signal s
@@ -27,7 +32,7 @@ let rec waitpid pid =
 let wait_and_clear pid stdout =
   Logs.debug (fun m -> m "waitpid() for pid %d" pid) ;
   waitpid pid >|= fun r ->
-  Vmm_commands.close_no_err stdout ;
+  Vmm_unix.close_no_err stdout ;
   match r with
   | Error () ->
     Logs.err (fun m -> m "waitpid() for %d returned error" pid) ;
@@ -36,8 +41,8 @@ let wait_and_clear pid stdout =
     Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ;
     ret s
 
-let read_exactly s =
-  let buf = Bytes.create 8 in
+let read_wire s =
+  let buf = Bytes.create 4 in
   let rec r b i l =
     Lwt.catch (fun () ->
         Lwt_unix.read s b i l >>= function
@@ -53,29 +58,28 @@ let read_exactly s =
          let err = Printexc.to_string e in
          Logs.err (fun m -> m "exception %s while reading" err) ;
          Lwt.return (Error `Exception))
-
   in
-  r buf 0 8 >>= function
+  r buf 0 4 >>= function
   | Error e -> Lwt.return (Error e)
   | Ok () ->
-    match Vmm_wire.parse_header (Bytes.to_string buf) with
-    | Error (`Msg m) -> Lwt.return (Error (`Msg m))
-    | Ok hdr ->
-      let l = hdr.Vmm_wire.length in
-      if l > 0 then
-        let b = Bytes.create l in
-        r b 0 l >|= function
+    let len = Cstruct.BE.get_uint32 (Cstruct.of_bytes buf) 0 in
+    if len > 0l then
+      let b = Bytes.create (Int32.to_int len) in
+      r b 0 (Int32.to_int len) >|= function
       | Error e -> Error e
       | Ok () ->
         (*          Logs.debug (fun m -> m "read hdr %a, body %a"
                          Cstruct.hexdump_pp (Cstruct.of_bytes buf)
                          Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *)
-          Ok (hdr, Bytes.to_string b)
+        match Vmm_asn.wire_of_cstruct (Cstruct.of_bytes b) with
+        | Ok w -> Ok w
+        | Error (`Msg msg) ->
+          Logs.err (fun m -> m "error %s while parsing data" msg) ;
+          Error `Exception
     else
-        Lwt.return (Ok (hdr, ""))
+        Lwt.return (Error `Eof)
 
 let write_raw s buf =
-  let buf = Bytes.unsafe_of_string buf in
   let rec w off l =
     Lwt.catch (fun () ->
         Lwt_unix.send s buf off l [] >>= fun n ->
@@ -89,3 +93,40 @@ let write_raw s buf =
   in
   (*  Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
   w 0 (Bytes.length buf)
+
+let write_wire s wire =
+  let data = Vmm_asn.wire_to_cstruct wire in
+  let dlen = Cstruct.create 4 in
+  Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
+  let buf = Cstruct.(to_bytes (append dlen data)) in
+  write_raw s buf
+
+let safe_close fd =
+  Lwt.catch
+    (fun () -> Lwt_unix.close fd)
+    (fun _ -> Lwt.return_unit)
+
+let read_from_file file =
+  Lwt.catch (fun () ->
+      Lwt_unix.stat file >>= fun stat ->
+      let size = stat.Lwt_unix.st_size in
+      Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd ->
+      Lwt.catch (fun () ->
+          let buf = Bytes.create size in
+          let rec read off =
+            Lwt_unix.read fd buf off (size - off) >>= fun bytes ->
+            if bytes + off = size then
+              Lwt.return_unit
+            else
+              read (bytes + off)
+          in
+          read 0 >>= fun () ->
+          safe_close fd >|= fun () ->
+          Cstruct.of_bytes buf)
+        (fun e ->
+           Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
+           safe_close fd >|= fun () ->
+           Cstruct.empty))
+    (fun e ->
+       Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
+       Lwt.return Cstruct.empty)

src/vmm_lwt.mli

@@ -0,0 +1,24 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit
+
+val pp_process_status : Format.formatter -> Unix.process_status -> unit
+
+val ret : Unix.process_status -> Vmm_core.process_exit
+
+val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t
+
+val wait_and_clear : int -> Unix.file_descr -> Vmm_core.process_exit Lwt.t
+
+val read_wire : Lwt_unix.file_descr ->
+  (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
+
+val write_raw :
+  Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t
+
+val write_wire :
+  Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
+
+val safe_close : Lwt_unix.file_descr -> unit Lwt.t
+
+val read_from_file : string -> Cstruct.t Lwt.t

src/vmm_resources.ml

@@ -1,8 +1,5 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-open Astring
-open Rresult.R.Infix
-
 open Vmm_core
 
 type res_entry = {
@@ -10,118 +7,113 @@ type res_entry = {
   used_memory : int ;
 }
 
-let pp_res_entry ppf res =
-  Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory
-
 let empty_res = { running_vms = 0 ; used_memory = 0 }
 
-let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) =
-  succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory
+let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
+  succ res.running_vms <= policy.vms &&
+  res.used_memory + vm.requested_memory <= policy.memory &&
+  vm_matches_res policy vm
+
+let check_resource_policy (policy : policy) (res : res_entry) =
+  res.running_vms <= policy.vms && res.used_memory <= policy.memory
 
 let add (vm : vm) (res : res_entry) =
   { running_vms = succ res.running_vms ;
     used_memory = vm.config.requested_memory + res.used_memory }
 
-let rem (vm : vm) (res : res_entry) =
-  { running_vms = pred res.running_vms ;
-    used_memory = res.used_memory - vm.config.requested_memory }
-
 type entry =
-  | Leaf of vm
-  | Subtree of res_entry * entry String.Map.t
+  | Vm of vm
+  | Policy of policy
 
-type t = entry String.Map.t
+type t = entry Vmm_trie.t
 
-let empty = String.Map.empty
+let pp ppf t =
+  Vmm_trie.fold [] t
+    (fun id ele () -> match ele with
+       | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
+       | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p)
+       ()
 
-let check_dynamic m vm policies =
-  (* for each policy (string * delegation), we need to look that vm + dynamic <= delegation *)
-  let rec go m = function
-    | [] -> Ok ()
-    | (nam,delegation)::rest ->
-      match String.Map.find nam m with
-      | None -> Ok ()
-      | Some (Leaf _) -> Error (`Msg "didn't expect a leaf here")
-      | Some (Subtree (r, m)) ->
-        if check_resource delegation vm r then
-          go m rest
-        else
-          Error (`Msg ("overcommitted at " ^ nam))
-  in
-  go m policies
+let empty = Vmm_trie.empty
 
-let rec pp_entry ppf = function
-  | Leaf vm -> pp_vm ppf vm
-  | Subtree (res, m) ->
-    Fmt.pf ppf "%a %a"
-      pp_res_entry res
-      Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
-      (String.Map.bindings m)
+let fold t name f g acc =
+  Vmm_trie.fold name t (fun prefix entry acc ->
+      match entry with
+      | Vm vm -> f prefix vm acc
+      | Policy p -> g prefix p acc) acc
 
-let pp ppf map =
-  Fmt.pf ppf "%a"
-    Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
-    (String.Map.bindings map)
+(* we should hide this type and confirm the following invariant:
+   - in case Vm, there are no siblings *)
 
-let find t name =
-  let rec find r m = function
-    | [] -> Some (Subtree (r, m))
-    | x::xs -> match String.Map.find x m with
-      | None -> None
-      | Some (Subtree (r, m)) -> find r m xs
-      | Some (Leaf vm) -> Some (Leaf vm)
-  in
-  find empty_res t name
+let resource_usage t name =
+  Vmm_trie.fold name t (fun _ entry acc ->
+      match entry with
+      | Policy _ -> acc
+      | Vm vm -> add vm acc)
+    empty_res
 
-let exists t name = match find t name with None -> false | Some _ -> true
-
-let find_vm t name = match find t name with
-  | Some (Leaf vm) -> Some vm
+let find_vm t name = match Vmm_trie.find name t with
+  | Some (Vm vm) -> Some vm
   | _ -> None
 
-let rec iter f = function
-  | Leaf vm -> f vm
-  | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m)
+let find_policy t name = match Vmm_trie.find name t with
+  | Some (Policy p) -> Some p
+  | _ -> None
 
-let rec fold f acc = function
-  | Leaf vm -> f acc vm
-  | Subtree (_, m) ->
-    List.fold_left (fun acc (_, e) -> fold f acc e) acc (String.Map.bindings m)
+let remove_vm t name =  match find_vm t name with
+  | None -> Error (`Msg "unknown vm")
+  | Some _ -> Ok (Vmm_trie.remove name t)
 
-let insert m name v =
-  let rec insert m = function
-    | [] -> Error (`Msg "ran out of labels during insert, this should not happen")
-    | [l] ->
-      begin match String.Map.find l m with
-        | None -> Ok (String.Map.add l (Leaf v) m)
-        | Some (Subtree _) -> Error (`Msg "found a subtree as last label")
-        | Some (Leaf _) -> Ok (String.Map.add l (Leaf v) m)
-      end
-    | l::ls ->
-      match String.Map.find l m with
-      | None ->
-        insert String.Map.empty ls >>= fun sub ->
-        Ok (String.Map.add l (Subtree (add v empty_res, sub)) m)
-      | Some (Subtree (r, m')) ->
-        insert m' ls >>= fun sub ->
-        Ok (String.Map.add l (Subtree (add v r, sub)) m)
-      | Some (Leaf _) -> Error (`Msg "should not happen: found leaf while still having labels")
-  in
-  insert m name
+let remove_policy t name = match find_policy t name with
+  | None -> Error (`Msg "unknown policy")
+  | Some _ -> Ok (Vmm_trie.remove name t)
 
-let remove m name vm =
-  let rec del m = function
-    | [] -> Error (`Msg "should not happen: empty labels in remove")
-    | [l] -> Ok (String.Map.remove l m)
-    | l::ls -> match String.Map.find l m with
-      | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels")
-      | Some (Subtree (r, m')) ->
-        del m' ls >>= fun m' ->
-        if String.Map.is_empty m' then
-          Ok (String.Map.remove l m)
+let check_vm_policy t name vm =
+  let dom = domain name in
+  let res = resource_usage t dom in
+  match Vmm_trie.find dom t with
+  | None -> true
+  | Some (Vm _) -> assert false
+  | Some (Policy p) -> check_resource p vm res
+
+let insert_vm t name vm =
+  if check_vm_policy t name vm.config then
+    match Vmm_trie.insert name (Vm vm) t with
+    | t', None -> Ok t'
+    | _, Some _ -> Error (`Msg "vm already exists")
   else
-          let res = rem vm r in
-          Ok (String.Map.add l (Subtree (res, m')) m)
-      | Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels")
-  in
-  del m name
+    Error (`Msg "resource policy mismatch")
+
+let check_policy_above t name p =
+  let above = Vmm_trie.collect name t in
+  List.for_all (fun (_, node) -> match node with
+      | Vm _ -> assert false
+      | Policy p' -> is_sub ~super:p' ~sub:p)
+    above
+
+let check_policy_below t name p =
+  Vmm_trie.fold name t (fun name entry res ->
+      match name with
+      | [] -> res
+      | _ ->
+        match res, entry with
+        | Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error ()
+        | Ok p, Vm vm ->
+          let cfg = vm.config in
+          if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
+          then Ok p
+          else Error ()
+        | res, _ -> res)
+    (Ok p)
+
+let insert_policy t name p =
+  let dom = domain name in
+  match
+    check_policy_above t dom p,
+    check_policy_below t name p,
+    check_resource_policy p (resource_usage t dom)
+  with
+  | true, Ok _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t))
+  | false, _, _ -> Error (`Msg "policy violates other policies above")
+  | _, Error (), _ -> Error (`Msg "policy violates other policies below")
+  | _, _, false -> Error (`Msg "more resources used than policy would allow")

src/vmm_resources.mli

@@ -1,6 +1,6 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-(** A tree data structure tracking dynamic resource usage.
+(** A tree data structure including policies and dynamic usage.
 
     Considering delegation of resources to someone, and further delegation
     to others - using a process which is not controlled by the authority -
@@ -14,43 +14,37 @@
 (** The type of the resource tree. *)
 type t
 
-(** The type of the resource tree entry. *)
-type entry
-
 (** [empty] is the empty tree. *)
 val empty : t
 
-(** [pp ppf t] pretty prints the tree. *)
-val pp : t Fmt.t
-
-(** [pp_entry ppf e] pretty prints the entry. *)
-val pp_entry : entry Fmt.t
-
-(** [check_dynamic t vm delegates] checks whether creating [vm] would violate
-    the policies of the [delegates] with respect to the running vms. *)
-val check_dynamic : t ->
-  Vmm_core.vm_config -> (string * Vmm_core.delegation) list ->
-  (unit, [> `Msg of string ]) result
-
-(** [exists t id] is [true] if the [id] already exists, [false] otherwise. *)
-val exists : t -> Vmm_core.id -> bool
-
-(** [find t id] is either [Some entry] or [None]. *)
-val find : t -> Vmm_core.id -> entry option
-
 (** [find_vm t id] is either [Some vm] or [None]. *)
 val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
 
-(** [iter f entry] applies [f] to each vm of [entry]. *)
-val iter : (Vmm_core.vm -> unit) -> entry -> unit
+(** [find_policy t id] is either [Some policy] or [None]. *)
+val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
 
-(** [fold f entry acc] folds [f] over [entry]. *)
-val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a
+(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
+    allowed under the current policies. *)
+val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool
 
-(** [insert t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
-    an error.  It also updates the resource usages on the path. *)
-val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
+(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
+    an error. *)
+val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
 
-(** [remove t id vm] removes [id] from [t], and returns the new [t] or an
-    error.  This also updates the resources usages on the path. *)
-val remove : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
+(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
+   the new [t] or an error. *)
+val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
+
+(** [remove_vm t id] removes vm [id] from [t]. *)
+val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
+
+(** [remove_policy t id] removes policy [id] from [t]. *)
+val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
+
+(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
+val fold : t -> Vmm_core.id ->
+  (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
+  (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a
+
+(** [pp] is a pretty printer for [t]. *)
+val pp : t Fmt.t

src/vmm_ring.ml

@@ -2,23 +2,41 @@
 
 (* a ring buffer with N strings, dropping old ones *)
 
-type t = {
-  data : (Ptime.t * string) array ;
+type 'a t = {
+  data : (Ptime.t * 'a) array ;
   mutable write : int ;
   size : int ;
 }
 
-let create ?(size = 1024) () =
-  { data = Array.make 1024 (Ptime.min, "") ; write = 0 ; size }
+let create ?(size = 1024) neutral () =
+  { data = Array.make 1024 (Ptime.min, neutral)  ; write = 0 ; size }
 
 let inc t = (succ t.write) mod t.size
 
-let write t v =
-  Array.set t.data t.write v ;
+let write t entry =
+  Array.set t.data t.write entry ;
   t.write <- inc t
 
 let dec t n = (pred n + t.size) mod t.size
 
+let written (ts, _) = not (Ptime.equal ts Ptime.min)
+
+let read t =
+  let rec go s acc idx =
+    if idx = s then (* don't read it twice *)
+      acc
+    else
+      let entry = Array.get t.data idx in
+      if written entry then go s (entry :: acc) (dec t idx)
+      else acc
+  in
+  let idx = dec t t.write in
+  let s =
+    let entry = Array.get t.data idx in
+    if written entry then [entry] else []
+  in
+  go idx s (dec t idx)
+
 let earlier ts than =
   if ts = Ptime.min then true
   else Ptime.is_earlier ts ~than

src/vmm_ring.mli

@@ -0,0 +1,9 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+type 'a t
+
+val create : ?size:int -> 'a -> unit -> 'a t
+
+val write : 'a t -> Ptime.t * 'a -> unit
+val read : 'a t -> (Ptime.t * 'a) list
+val read_history : 'a t -> Ptime.t -> (Ptime.t * 'a) list

src/vmm_tls.ml

@@ -1,59 +1,92 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
 
-open Lwt.Infix
+open Rresult
+open Rresult.R.Infix
 
-let read_tls t =
-  let rec r_n buf off tot =
-    let l = tot - off in
-    if l = 0 then
-      Lwt.return (Ok ())
+(* we skip all non-albatross certificates *)
+let cert_name cert =
+  match X509.Extension.unsupported cert Vmm_asn.oid with
+  | None -> Ok None
+  | Some (_, data) ->
+    let name = X509.common_name_to_string cert in
+    if name = "" then
+      match Vmm_asn.cert_extension_of_cstruct data with
+      | Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension")
+      | Ok (_, `Policy_cmd (`Policy_add _)) -> Error (`Msg "policy add may not have an empty name")
+      | _ -> Ok None
+    else Ok (Some name)
+
+let name chain =
+  List.fold_left (fun acc cert ->
+      match acc, cert_name cert with
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+      | Ok acc, Ok None -> Ok acc
+      | Ok acc, Ok Some data -> Ok (data :: acc))
+    (Ok []) chain
+
+(* this separates the leaf and top-level certificate from the chain,
+   and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
+   in which subCA' signed leaf *)
+let separate_chain = function
+  | [] -> Error (`Msg "empty chain")
+  | [ leaf ] -> Ok (leaf, [])
+  | leaf :: xs -> Ok (leaf, List.rev xs)
+
+let wire_command_of_cert version cert =
+  match X509.Extension.unsupported cert Vmm_asn.oid with
+  | None -> Error `Not_present
+  | Some (_, data) ->
+    match Vmm_asn.cert_extension_of_cstruct data with
+    | Error (`Msg p) -> Error (`Parse p)
+    | Ok (v, wire) ->
+      if not (Vmm_commands.version_eq v version) then
+        Error (`Version v)
       else
-      Lwt.catch (fun () ->
-          Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
-          | 0 ->
-            Logs.err (fun m -> m "TLS: end of file") ;
-            Lwt.return (Error `Eof)
-          | x when x == l -> Lwt.return (Ok ())
-          | x when x < l -> r_n buf (off + x) tot
-          | _ ->
-            Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
-            Lwt.return (Error `Toomuch))
-        (function
-          | Tls_lwt.Tls_failure a ->
-            Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
-            Lwt.return (Error `Exception)
-          | e ->
-            Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
-            Lwt.return (Error `Exception))
-  in
-  let buf = Cstruct.create 8 in
-  r_n buf 0 8 >>= function
-  | Error e -> Lwt.return (Error e)
-  | Ok () ->
-    match Vmm_wire.parse_header (Cstruct.to_string buf) with
-    | Error (`Msg m) -> Lwt.return (Error (`Msg m))
-    | Ok hdr ->
-      let l = hdr.Vmm_wire.length in
-      if l > 0 then
-        let b = Cstruct.create l in
-        r_n b 0 l >|= function
-        | Error e -> Error e
-        | Ok () ->
-(*          Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a"
-                         hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag
-                         Cstruct.hexdump_pp b) ; *)
-          Ok (hdr, Cstruct.to_string b)
-      else
-        Lwt.return (Ok (hdr, ""))
+        Ok wire
 
-let write_tls s buf =
-  (*  Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
-  Lwt.catch
-    (fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ())
-    (function
-      | Tls_lwt.Tls_failure a ->
-        Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
-        Lwt.return (Error `Exception)
-      | e ->
-        Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
-        Lwt.return (Error `Exception))
+let extract_policies version chain =
+  List.fold_left (fun acc cert ->
+      match acc, wire_command_of_cert version cert with
+      | Error e, _ -> Error e
+      | Ok acc, Error `Not_present -> Ok acc
+      | Ok _, Error (`Parse msg) -> Error (`Msg msg)
+      | Ok _, Error (`Version received) ->
+        R.error_msgf "unexpected version %a (expected %a)"
+          Vmm_commands.pp_version received
+          Vmm_commands.pp_version version
+      | Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
+        (cert_name cert >>| function
+          | None -> prefix
+          | Some x -> x :: prefix) >>| fun name ->
+        (name, (name, p) :: acc)
+      | _, Ok wire ->
+        R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
+    (Ok ([], [])) chain
+
+let handle _addr version chain =
+  separate_chain chain >>= fun (leaf, rest) ->
+  name chain >>= fun name ->
+  Logs.debug (fun m -> m "leaf is %s, chain %a"
+                 (X509.common_name_to_string leaf)
+                 Fmt.(list ~sep:(unit " -> ") string)
+                 (List.map X509.common_name_to_string rest)) ;
+  extract_policies version rest >>= fun (_, policies) ->
+  (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
+  match wire_command_of_cert version leaf with
+  | Error (`Parse p) -> Error (`Msg p)
+  | Error (`Not_present) ->
+    Error (`Msg "leaf certificate does not contain an albatross extension")
+  | Error (`Version received) ->
+    R.error_msgf "unexpected version %a (expected %a)"
+      Vmm_commands.pp_version received
+      Vmm_commands.pp_version version
+  | Ok wire ->
+    (* we only allow some commands via certificate *)
+    match wire with
+    | `Console_cmd (`Console_subscribe _)
+    | `Stats_cmd `Stats_subscribe
+    | `Log_cmd (`Log_subscribe _)
+    | `Vm_cmd _
+    | `Policy_cmd `Policy_info -> Ok (name, policies, wire)
+    | _ -> Error (`Msg "unexpected command")

src/vmm_tls.mli

@@ -0,0 +1,10 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+val wire_command_of_cert : Vmm_commands.version -> X509.t ->
+  (Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result
+
+val handle :
+  'a -> Vmm_commands.version ->
+  X509.t list ->
+  (Vmm_core.id * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t,
+   [> `Msg of string ]) Result.result

src/vmm_tls_lwt.ml

@@ -0,0 +1,69 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+let read_tls t =
+  let rec r_n buf off tot =
+    let l = tot - off in
+    if l = 0 then
+      Lwt.return (Ok ())
+    else
+      Lwt.catch (fun () ->
+          Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
+          | 0 ->
+            Logs.err (fun m -> m "TLS: end of file") ;
+            Lwt.return (Error `Eof)
+          | x when x == l -> Lwt.return (Ok ())
+          | x when x < l -> r_n buf (off + x) tot
+          | _ ->
+            Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
+            Lwt.return (Error `Toomuch))
+        (function
+          | Tls_lwt.Tls_failure a ->
+            Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
+            Lwt.return (Error `Exception)
+          | e ->
+            Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
+            Lwt.return (Error `Exception))
+  in
+  let buf = Cstruct.create 4 in
+  r_n buf 0 4 >>= function
+  | Error e -> Lwt.return (Error e)
+  | Ok () ->
+    let len = Cstruct.BE.get_uint32 buf 0 in
+    if len > 0l then
+      let b = Cstruct.create (Int32.to_int len) in
+      r_n b 0 (Int32.to_int len) >|= function
+      | Error e -> Error e
+      | Ok () ->
+        (*          Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a"
+                         hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag
+                         Cstruct.hexdump_pp b) ; *)
+        match Vmm_asn.wire_of_cstruct b with
+        | Ok w -> Ok w
+        | Error (`Msg msg) ->
+          Logs.err (fun m -> m "error %s while parsing data" msg) ;
+          Error `Exception
+      else
+        Lwt.return (Error `Eof)
+
+let write_tls s wire =
+  let data = Vmm_asn.wire_to_cstruct wire in
+  let dlen = Cstruct.create 4 in
+  Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
+  let buf = Cstruct.(append dlen data) in
+  (*  Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
+  Lwt.catch
+    (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ())
+    (function
+      | Tls_lwt.Tls_failure a ->
+        Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
+        Lwt.return (Error `Exception)
+      | e ->
+        Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
+        Lwt.return (Error `Exception))
+
+let close tls =
+  Lwt.catch
+    (fun () -> Tls_lwt.Unix.close tls)
+    (fun _ -> Lwt.return_unit)

src/vmm_tls_lwt.mli

@@ -0,0 +1,9 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+val read_tls : Tls_lwt.Unix.t ->
+  (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
+
+val write_tls :
+  Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
+
+val close : Tls_lwt.Unix.t -> unit Lwt.t

src/vmm_trie.ml

@@ -0,0 +1,99 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+type 'a t = N of 'a option * 'a t String.Map.t
+
+let empty = N (None, String.Map.empty)
+
+let insert id e t =
+  let rec go (N (es, m)) = function
+    | [] ->
+      begin match es with
+        | None -> N (Some e, m), None
+        | Some es' -> N (Some e, m), Some es'
+      end
+    | x::xs ->
+      let n = match String.Map.find_opt x m with
+        | None -> empty
+        | Some n -> n
+      in
+      let entry, ret = go n xs in
+      N (es, String.Map.add x entry m), ret
+  in
+  go t id
+
+let remove id t =
+  let rec go (N (es, m)) = function
+    | [] -> if String.Map.is_empty m then None else Some (N (None, m))
+    | x::xs ->
+      let n' = match String.Map.find_opt x m with
+        | None -> None
+        | Some n -> go n xs
+      in
+      let m' = match n' with
+        | None -> String.Map.remove x m
+        | Some entry -> String.Map.add x entry m
+      in
+      if String.Map.is_empty m' && es = None then None else Some (N (es, m'))
+  in
+  match go t id with
+  | None -> empty
+  | Some n -> n
+
+let find id t =
+  let rec go (N (es, m)) = function
+    | [] -> es
+    | x::xs ->
+      match String.Map.find_opt x m with
+      | None -> None
+      | Some n -> go n xs
+  in
+  go t id
+
+let collect id t =
+  let rec go acc prefix (N (es, m)) =
+    let acc' =
+      match es with
+      | None -> acc
+      | Some e -> (prefix, e) :: acc
+    in
+    function
+    | [] -> acc'
+    | x::xs ->
+      match String.Map.find_opt x m with
+      | None -> acc'
+      | Some n -> go acc' (prefix @ [ x ]) n xs
+  in
+  go [] [] t id
+
+let all t =
+  let rec go acc prefix (N (es, m)) =
+    let acc' =
+      match es with
+      | None -> acc
+      | Some e -> (prefix, e) :: acc
+    in
+    List.fold_left (fun acc (name, node) ->
+        go acc (prefix@[name]) node)
+      acc' (String.Map.bindings m)
+  in
+  go [] [] t
+
+let fold id t f acc =
+  let rec explore (N (es, m)) prefix acc =
+    let acc' =
+      String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc)
+        m acc
+    in
+    match es with
+    | None -> acc'
+    | Some e -> f prefix e acc'
+  and down prefix (N (es, m)) =
+    match prefix with
+    | [] -> explore (N (es, m)) [] acc
+    | x :: xs -> match String.Map.find_opt x m with
+      | None -> acc
+      | Some n -> down xs n
+  in
+  down id t

src/vmm_trie.mli

@@ -0,0 +1,19 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Vmm_core
+
+type 'a t
+
+val empty : 'a t
+
+val insert : id -> 'a -> 'a t -> 'a t * 'a option
+
+val remove : id -> 'a t -> 'a t
+
+val find : id -> 'a t -> 'a option
+
+val collect : id -> 'a t -> (id * 'a) list
+
+val all : 'a t -> (id * 'a) list
+
+val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b

src/vmm_unix.ml

@@ -0,0 +1,180 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Rresult
+(* bits copied over from Bos *)
+(*---------------------------------------------------------------------------
+   Copyright (c) 2014 Daniel C. Bünzli
+
+   Permission to use, copy, modify, and/or distribute this software for any
+   purpose with or without fee is hereby granted, provided that the above
+   copyright notice and this permission notice appear in all copies.
+
+   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+  ---------------------------------------------------------------------------*)
+let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
+
+let err_empty_line = "no command, empty command line"
+let err_file f e = R.error_msgf "%a: %a" Fpath.pp f pp_unix_error e
+
+let rec openfile fn mode perm = try Unix.openfile fn mode perm with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> openfile fn mode perm
+
+let fd_for_file flag f =
+  try Ok (openfile (Fpath.to_string f) (Unix.O_CLOEXEC :: flag) 0o644)
+  with Unix.Unix_error (e, _, _) -> err_file f e
+
+let read_fd_for_file = fd_for_file Unix.[ O_RDONLY ]
+
+let write_fd_for_file = fd_for_file Unix.[ O_WRONLY ; O_APPEND ]
+
+let null = match read_fd_for_file (Fpath.v "/dev/null") with
+  | Ok fd -> fd
+  | Error _ -> invalid_arg "cannot read /dev/null"
+
+let rec create_process prog args stdout stderr =
+  try Unix.create_process prog args null stdout stderr with
+  | Unix.Unix_error (Unix.EINTR, _, _) ->
+      create_process prog args stdout stderr
+
+let rec close fd =
+  try Unix.close fd with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> close fd
+
+let close_no_err fd = try close fd with _ -> ()
+
+(* own code starts here
+   (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Vmm_core
+
+let rec mkfifo name =
+  try Unix.mkfifo (Fpath.to_string name) 0o640 with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
+
+let image_file, fifo_file =
+  ((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")),
+   (fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name))))
+
+let rec fifo_exists file =
+  try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
+  | Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
+  | Unix.Unix_error (Unix.EINTR, _, _) -> fifo_exists file
+  | Unix.Unix_error (e, _, _) ->
+      R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
+
+let uname () =
+  let cmd = Bos.Cmd.(v "uname" % "-s") in
+  lazy Bos.OS.Cmd.(run_out cmd |> out_string)
+
+let create_tap bridge =
+  Lazy.force (uname ()) >>= fun (sys, _) ->
+  match sys with
+  | x when x = "FreeBSD" ->
+    let cmd = Bos.Cmd.(v "ifconfig" % "tap" % "create") in
+    Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
+    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % bridge % "addm" % name) >>= fun () ->
+    Ok name
+  | x when x = "Linux" ->
+    let prefix = "vmmtap" in
+    let rec find_n x =
+      let nam = prefix ^ string_of_int x in
+      match Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % nam) with
+      | Error _ -> nam
+      | Ok _ -> find_n (succ x)
+    in
+    let tap = find_n 0 in
+    Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "add" % "mode" % "tap" % tap) >>= fun () ->
+    Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addif" % bridge % tap) >>= fun () ->
+    Ok tap
+  | x -> Error (`Msg ("unsupported operating system " ^ x))
+
+let destroy_tap tapname =
+  Lazy.force (uname ()) >>= fun (sys, _) ->
+  match sys with
+  | x when x = "FreeBSD" ->
+    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % tapname % "destroy")
+  | x when x = "Linux" ->
+    Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
+  | x -> Error (`Msg ("unsupported operating system " ^ x))
+
+let prepare name vm =
+  (match vm.vmimage with
+   | `Hvt_amd64, blob -> Ok blob
+   | `Hvt_amd64_compressed, blob ->
+     begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
+       | Ok blob -> Ok (Cstruct.of_string blob)
+       | Error () -> Error (`Msg "failed to uncompress")
+     end
+   | `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
+  let fifo = fifo_file name in
+  (match fifo_exists fifo with
+   | Ok true -> Ok ()
+   | Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
+   | Error _ ->
+     try Ok (mkfifo fifo) with
+     | Unix.Unix_error (e, f, _) ->
+       Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
+       Error (`Msg "while creating fifo")) >>= fun () ->
+  List.fold_left (fun acc b ->
+      acc >>= fun acc ->
+      create_tap b >>= fun tap ->
+      Ok (tap :: acc))
+    (Ok []) vm.network >>= fun taps ->
+  Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () ->
+  Ok (List.rev taps)
+
+let shutdown name vm =
+  (* same order as prepare! *)
+  Bos.OS.File.delete (image_file name) >>= fun () ->
+  Bos.OS.File.delete (fifo_file name) >>= fun () ->
+  List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
+
+let cpuset cpu =
+  Lazy.force (uname ()) >>= fun (sys, _) ->
+  let cpustring = string_of_int cpu in
+  match sys with
+  | x when x = "FreeBSD" ->
+    Ok ([ "cpuset" ; "-l" ; cpustring ])
+  | x when x = "Linux" ->
+    Ok ([ "taskset" ; "-c" ; cpustring ])
+  | x -> Error (`Msg ("unsupported operating system " ^ x))
+
+let exec name vm taps =
+  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.(dbdir / "solo5-hvt.none")
+   | [_] -> Ok Fpath.(dbdir / "solo5-hvt.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
+  let cmd =
+    Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
+             "--" % p (image_file name) %% of_list argv)
+  in
+  let line = Bos.Cmd.to_list cmd in
+  let prog = try List.hd line with Failure _ -> failwith err_empty_line in
+  let line = Array.of_list line in
+  let fifo = fifo_file name in
+  Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
+  write_fd_for_file fifo >>= fun stdout ->
+  Logs.debug (fun m -> m "opened file descriptor!");
+  try
+    Logs.debug (fun m -> m "creating process");
+    let pid = create_process prog line stdout stdout in
+    Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
+    (* this should get rid of the vmimage from vmmd's memory! *)
+    let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
+    Ok { config ; cmd ; pid ; taps ; stdout }
+  with
+    Unix.Unix_error (e, _, _) ->
+    close_no_err stdout;
+    R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
+
+let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)

src/vmm_unix.mli

@@ -0,0 +1,15 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Rresult
+
+open Vmm_core
+
+val prepare : id -> vm_config -> (string list, [> R.msg ]) result
+
+val shutdown : id -> vm -> (unit, [> R.msg ]) result
+
+val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
+
+val destroy : vm -> unit
+
+val close_no_err : Unix.file_descr -> unit

src/vmm_vmmd.ml

@@ -0,0 +1,200 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+open Vmm_core
+
+open Rresult
+open R.Infix
+
+type 'a t = {
+  wire_version : Vmm_commands.version ;
+  console_counter : int64 ;
+  stats_counter : int64 ;
+  log_counter : int64 ;
+  resources : Vmm_resources.t ;
+  tasks : 'a String.Map.t ;
+}
+
+let init wire_version = {
+  wire_version ;
+  console_counter = 1L ;
+  stats_counter = 1L ;
+  log_counter = 1L ;
+  resources = Vmm_resources.empty ;
+  tasks = String.Map.empty ;
+}
+
+type service_out = [
+  | `Stat of Vmm_commands.wire
+  | `Log of Vmm_commands.wire
+  | `Cons of Vmm_commands.wire
+]
+
+type out = [ service_out | `Data of Vmm_commands.wire ]
+
+let log t id event =
+  let data = (Ptime_clock.now (), event) in
+  let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in
+  let log_counter = Int64.succ t.log_counter in
+  Logs.debug (fun m -> m "log %a" Log.pp data) ;
+  ({ t with log_counter }, `Log (header, `Data (`Log_data data)))
+
+let handle_create t hdr vm_config =
+  let name = hdr.Vmm_commands.id in
+  (match Vmm_resources.find_vm t.resources name with
+   | Some _ -> Error (`Msg "VM with same name is already running")
+   | None -> Ok ()) >>= fun () ->
+  Logs.debug (fun m -> m "now checking resource policies") ;
+  (if Vmm_resources.check_vm_policy t.resources name vm_config then
+     Ok ()
+   else
+     Error (`Msg "resource policies don't allow this")) >>= fun () ->
+  (* prepare VM: save VM image to disk, create fifo, ... *)
+  Vmm_unix.prepare name vm_config >>= fun taps ->
+  Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
+  let cons_out =
+    let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
+    (header, `Command (`Console_cmd `Console_add))
+  in
+  Ok ({ t with console_counter = Int64.succ t.console_counter },
+      [ `Cons cons_out ],
+      `Create (fun t task ->
+          (* actually execute the vm *)
+          Vmm_unix.exec name vm_config taps >>= fun vm ->
+          Logs.debug (fun m -> m "exec()ed vm") ;
+          Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
+          let tasks = String.Map.add (string_of_id name) task t.tasks in
+          let t = { t with resources ; tasks } in
+          let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in
+          let data = `Success (`String "created VM") in
+          Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
+
+let setup_stats t name vm =
+  let stat_out = `Stats_add (vm.pid, vm.taps) in
+  let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
+  let t = { t with stats_counter = Int64.succ t.stats_counter } in
+  t, `Stat (header, `Command (`Stats_cmd stat_out))
+
+let handle_shutdown t name vm r =
+  (match Vmm_unix.shutdown name vm with
+   | Ok () -> ()
+   | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
+  let resources = match Vmm_resources.remove_vm t.resources name with
+    | Error (`Msg e) ->
+      Logs.warn (fun m -> m "%s while removing vm %a from resources" e pp_vm vm) ;
+      t.resources
+    | Ok resources -> resources
+  in
+  let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
+  let tasks = String.Map.remove (string_of_id name) t.tasks in
+  let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
+  let t, logout = log t name (`Vm_stop (name, vm.pid, r))
+  in
+  (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
+
+let handle_command t (header, payload) =
+  let msg_to_err = function
+    | Ok x -> x
+    | Error (`Msg msg) ->
+      Logs.debug (fun m -> m "error while processing command: %s" msg) ;
+      (t, [ `Data (header, `Failure msg) ], `End)
+  in
+  let reply x = `Data (header, `Success x) in
+  msg_to_err (
+    let id = header.Vmm_commands.id in
+    match payload with
+    | `Command (`Policy_cmd pc) ->
+      begin match pc with
+        | `Policy_remove ->
+          Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
+          Vmm_resources.remove_policy t.resources id >>= fun resources ->
+          Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
+        | `Policy_add policy ->
+          Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
+          let same_policy = match Vmm_resources.find_policy t.resources id with
+            | None -> false
+            | Some p' -> eq_policy policy p'
+          in
+          if same_policy then
+            Ok (t, [ reply (`String "no modification of policy") ], `End)
+          else
+            Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
+            Ok ({ t with resources }, [ reply (`String "added policy") ], `End)
+        | `Policy_info ->
+          begin
+            Logs.debug (fun m -> m "policy %a" pp_id id) ;
+            let policies =
+              Vmm_resources.fold t.resources id
+                (fun _ _ policies -> policies)
+                (fun prefix policy policies-> (prefix, policy) :: policies)
+                []
+            in
+            match policies with
+            | [] ->
+              Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ;
+              Error (`Msg "policy: not found")
+            | _ ->
+              Ok (t, [ reply (`Policies policies) ], `End)
+          end
+      end
+    | `Command (`Vm_cmd vc) ->
+      begin match vc with
+        | `Vm_info ->
+          Logs.debug (fun m -> m "info %a" pp_id id) ;
+          let vms =
+            Vmm_resources.fold t.resources id
+              (fun id vm vms -> (id, vm.config) :: vms)
+              (fun _ _ vms-> vms)
+              []
+          in
+          begin match vms with
+            | [] ->
+              Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
+              Error (`Msg "info: not found")
+            | _ ->
+              Ok (t, [ reply (`Vms vms) ], `End)
+          end
+        | `Vm_create vm_config ->
+          handle_create t header vm_config
+        | `Vm_force_create vm_config ->
+          let resources =
+            match Vmm_resources.remove_vm t.resources id with
+            | Error _ -> t.resources
+            | Ok r -> r
+          in
+          if Vmm_resources.check_vm_policy resources id vm_config then
+            begin match Vmm_resources.find_vm t.resources id with
+              | None -> handle_create t header vm_config
+              | Some vm ->
+                Vmm_unix.destroy vm ;
+                let id_str = string_of_id id in
+                match String.Map.find_opt id_str t.tasks with
+                | None -> handle_create t header vm_config
+                | Some task ->
+                  let tasks = String.Map.remove id_str t.tasks in
+                  let t = { t with tasks } in
+                  Ok (t, [], `Wait_and_create
+                        (task, fun t -> msg_to_err @@ handle_create t header vm_config))
+            end
+          else
+            Error (`Msg "wouldn't match policy")
+        | `Vm_destroy ->
+          begin match Vmm_resources.find_vm t.resources id with
+            | Some vm ->
+              Vmm_unix.destroy vm ;
+              let id_str = string_of_id id in
+              let out, next =
+                let s = reply (`String "destroyed vm") in
+                match String.Map.find_opt id_str t.tasks with
+                | None -> [ s ], `End
+                | Some t -> [], `Wait (t, s)
+              in
+              let tasks = String.Map.remove id_str t.tasks in
+              Ok ({ t with tasks }, out, next)
+            | None -> Error (`Msg "destroy: not found")
+          end
+      end
+    | _ ->
+      Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
+      Error (`Msg "unknown command"))

src/vmm_vmmd.mli

@@ -0,0 +1,27 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+type 'a t
+
+val init : Vmm_commands.version -> 'a t
+
+type service_out = [
+  | `Stat of Vmm_commands.wire
+  | `Log of Vmm_commands.wire
+  | `Cons of Vmm_commands.wire
+]
+
+type out = [ service_out | `Data of Vmm_commands.wire ]
+
+val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
+  [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
+
+val handle_command : 'a t -> Vmm_commands.wire ->
+  'a t * out list *
+  [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> `Msg of string ]) result
+  | `End
+  | `Wait of 'a * out
+  | `Wait_and_create of 'a * ('a t -> 'a t * out list *
+                                      [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
+                                      | `End ]) ]
+
+val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out

src/vmm_wire.ml

@@ -1,697 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-(* the wire protocol - length prepended binary data *)
-
-(* each message (on all channels) is prefixed by a common header:
-   - length (16 bit) spanning the message (excluding the 8 bytes header)
-   - id (16 bit) unique id chosen by sender (for request/reply) - 0 shouldn't be used (reserved for log/console messages which do not correspond to a request)
-   - version (16 bit) the version used on this channel
-   - tag (16 bit) the type of message
-
-   Version and tag are protocol-specific - the channel between vmm and console
-   uses different tags and mayuse a different version than between vmm and
-   client. *)
-
-open Astring
-
-open Vmm_core
-
-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"
-      | `WV1 -> "wire version 1")
-
-type header = {
-  length : int ;
-  id : int ;
-  version : version ;
-  tag : int ;
-}
-
-open Rresult
-open R.Infix
-
-let check_len cs l =
-  if Cstruct.len cs < l then
-    Error (`Msg "underflow")
-  else
-    Ok ()
-
-let check_exact cs l =
-  if Cstruct.len cs = l then
-    Ok ()
-  else
-    Error (`Msg "bad length")
-
-let empty = Cstruct.create 0
-
-let null cs = if Cstruct.len cs = 0 then Ok () else Error (`Msg "trailing bytes")
-
-let parse_header buf =
-  let cs = Cstruct.of_string buf in
-  check_len cs 8 >>= fun () ->
-  let length = Cstruct.BE.get_uint16 cs 0
-  and id = Cstruct.BE.get_uint16 cs 2
-  and version = Cstruct.BE.get_uint16 cs 4
-  and tag = Cstruct.BE.get_uint16 cs 6
-  in
-  version_of_int version >>= fun version ->
-  Ok { length ; id ; version ; tag }
-
-let create_header { length ; id ; version ; tag } =
-  let hdr = Cstruct.create 8 in
-  Cstruct.BE.set_uint16 hdr 0 length ;
-  Cstruct.BE.set_uint16 hdr 2 id ;
-  Cstruct.BE.set_uint16 hdr 4 (version_to_int version) ;
-  Cstruct.BE.set_uint16 hdr 6 tag ;
-  hdr
-
-let decode_string cs =
-  check_len cs 2 >>= fun () ->
-  let l = Cstruct.BE.get_uint16 cs 0 in
-  check_len cs (2 + l) >>= fun () ->
-  let str = Cstruct.(to_string (sub cs 2 l)) in
-  Ok (str, l + 2)
-
-(* external use only *)
-let decode_str str =
-  if String.length str = 0 then
-    Ok ("", 0)
-  else
-    decode_string (Cstruct.of_string str)
-
-let decode_strings cs =
-  let rec go acc buf =
-    if Cstruct.len buf = 0 then
-      Ok (List.rev acc)
-    else
-      decode_string buf >>= fun (x, l) ->
-      go (x :: acc) (Cstruct.shift buf l)
-  in
-  go [] cs
-
-let encode_string str =
-  let l = String.length str in
-  let cs = Cstruct.create (2 + l) in
-  Cstruct.BE.set_uint16 cs 0 l ;
-  Cstruct.blit_from_string str 0 cs 2 l ;
-  cs, 2 + l
-
-let encode_strings xs =
-  Cstruct.concat
-    (List.map (fun s -> fst (encode_string s)) xs)
-
-let max = Int64.of_int max_int
-let min = Int64.of_int min_int
-
-let decode_int ?(off = 0) cs =
-  let i = Cstruct.BE.get_uint64 cs off in
-  if i > max then
-    Error (`Msg "int too big")
-  else if i < min then
-    Error (`Msg "int too small")
-  else
-    Ok (Int64.to_int i)
-
-let encode_int i =
-  let cs = Cstruct.create 8 in
-  Cstruct.BE.set_uint64 cs 0 (Int64.of_int i) ;
-  cs
-
-(* TODO: 32 bit system clean *)
-let decode_pid cs =
-  check_len cs 4 >>= fun () ->
-  let pid = Cstruct.BE.get_uint32 cs 0 in
-  Ok (Int32.to_int pid)
-
-(* TODO: can we do sth more appropriate than raise? *)
-let encode_pid pid =
-  let cs = Cstruct.create 4 in
-  if Int32.to_int Int32.max_int > pid &&
-     Int32.to_int Int32.min_int < pid
-  then begin
-    Cstruct.BE.set_uint32 cs 0 (Int32.of_int pid) ;
-    cs
-  end else
-    invalid_arg "pid too big"
-
-let decode_ptime cs =
-  check_len cs 16 >>= fun () ->
-  decode_int cs >>= fun d ->
-  let ps = Cstruct.BE.get_uint64 cs 8 in
-  Ok (Ptime.v (d, ps))
-
-(* EXPORT only *)
-let decode_ts ?(off = 0) buf =
-  let cs = Cstruct.of_string buf in
-  let cs = Cstruct.shift cs off in
-  decode_ptime cs
-
-let encode_ptime ts =
-  let d, ps = Ptime.(Span.to_d_ps (to_span ts)) in
-  let cs = Cstruct.create 16 in
-  Cstruct.BE.set_uint64 cs 0 (Int64.of_int d) ;
-  Cstruct.BE.set_uint64 cs 8 ps ;
-  cs
-
-let fail_tag = 0xFFFE
-let success_tag = 0xFFFF
-
-let may_enc_str = function
-  | None -> empty, 0
-  | Some msg -> encode_string msg
-
-let success ?msg id version =
-  let data, length = may_enc_str msg in
-  let r =
-    Cstruct.append
-      (create_header { length ; id ; version ; tag = success_tag }) data
-  in
-  Cstruct.to_string r
-
-let fail ?msg id version =
-  let data, length = may_enc_str msg in
-  let r =
-    Cstruct.append
-      (create_header { length ; id ; version ; tag =  fail_tag }) data
-  in
-  Cstruct.to_string r
-
-module Console = struct
-  [%%cenum
-    type op =
-      | Add_console
-      | Attach_console
-      | Detach_console
-      | History
-      | Data
-    [@@uint16_t]
-  ]
-
-  let encode id version op ?payload nam =
-    let data, l = encode_string nam in
-    let length, p =
-      match payload with
-      | None -> l, empty
-      | Some x -> l + Cstruct.len x, x
-    and tag = op_to_int op
-    in
-    let r =
-      Cstruct.concat
-        [ (create_header { length ; id ; version ; tag }) ; data ; p ]
-    in
-    Cstruct.to_string r
-
-  let data ?(id = 0) v file ts msg =
-    let payload =
-      let ts = encode_ptime ts
-      and data, _ = encode_string msg
-      in
-      Cstruct.append ts data
-    in
-    encode id v Data ~payload file
-
-  let add id v name = encode id v Add_console name
-
-  let attach id v name = encode id v Attach_console name
-
-  let detach id v name = encode id v Detach_console name
-
-  let history id v name since =
-    let payload = encode_ptime since in
-    encode id v History ~payload name
-end
-
-module Stats = struct
-  [%%cenum
-    type op =
-      | Add
-      | Remove
-      | Stat_request
-      | Stat_reply
-    [@@uint16_t]
-  ]
-
-  let encode id version op ?payload nam =
-    let data, l = encode_string nam in
-    let length, p =
-      match payload with
-      | None -> l, empty
-      | Some x -> l + Cstruct.len x, x
-    and tag = op_to_int op
-    in
-    let r =
-      Cstruct.concat [ create_header { length ; version ; id ; tag } ; data ; p ]
-    in
-    Cstruct.to_string r
-
-  let encode_rusage ru =
-    let cs = Cstruct.create (18 * 8) in
-    Cstruct.BE.set_uint64 cs 0 (fst ru.utime) ;
-    Cstruct.BE.set_uint64 cs 8 (Int64.of_int (snd ru.utime)) ;
-    Cstruct.BE.set_uint64 cs 16 (fst ru.stime) ;
-    Cstruct.BE.set_uint64 cs 24 (Int64.of_int (snd ru.stime)) ;
-    Cstruct.BE.set_uint64 cs 32 ru.maxrss ;
-    Cstruct.BE.set_uint64 cs 40 ru.ixrss ;
-    Cstruct.BE.set_uint64 cs 48 ru.idrss ;
-    Cstruct.BE.set_uint64 cs 56 ru.isrss ;
-    Cstruct.BE.set_uint64 cs 64 ru.minflt ;
-    Cstruct.BE.set_uint64 cs 72 ru.majflt ;
-    Cstruct.BE.set_uint64 cs 80 ru.nswap ;
-    Cstruct.BE.set_uint64 cs 88 ru.inblock ;
-    Cstruct.BE.set_uint64 cs 96 ru.outblock ;
-    Cstruct.BE.set_uint64 cs 104 ru.msgsnd ;
-    Cstruct.BE.set_uint64 cs 112 ru.msgrcv ;
-    Cstruct.BE.set_uint64 cs 120 ru.nsignals ;
-    Cstruct.BE.set_uint64 cs 128 ru.nvcsw ;
-    Cstruct.BE.set_uint64 cs 136 ru.nivcsw ;
-    cs
-
-  let decode_rusage cs =
-    check_exact cs 144 >>= fun () ->
-    (decode_int ~off:8 cs >>= fun ms ->
-     Ok (Cstruct.BE.get_uint64 cs 0, ms)) >>= fun utime ->
-    (decode_int ~off:24 cs >>= fun ms ->
-     Ok (Cstruct.BE.get_uint64 cs 16, ms)) >>= fun stime ->
-    let maxrss = Cstruct.BE.get_uint64 cs 32
-    and ixrss = Cstruct.BE.get_uint64 cs 40
-    and idrss = Cstruct.BE.get_uint64 cs 48
-    and isrss = Cstruct.BE.get_uint64 cs 56
-    and minflt = Cstruct.BE.get_uint64 cs 64
-    and majflt = Cstruct.BE.get_uint64 cs 72
-    and nswap = Cstruct.BE.get_uint64 cs 80
-    and inblock = Cstruct.BE.get_uint64 cs 88
-    and outblock = Cstruct.BE.get_uint64 cs 96
-    and msgsnd = Cstruct.BE.get_uint64 cs 104
-    and msgrcv = Cstruct.BE.get_uint64 cs 112
-    and nsignals = Cstruct.BE.get_uint64 cs 120
-    and nvcsw = Cstruct.BE.get_uint64 cs 128
-    and nivcsw = Cstruct.BE.get_uint64 cs 136
-    in
-    Ok { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ;
-         nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
-
-  let encode_ifdata i =
-    let name, _ = encode_string i.name in
-    let cs = Cstruct.create (12 * 8 + 5 * 4) in
-    Cstruct.BE.set_uint32 cs 0 i.flags ;
-    Cstruct.BE.set_uint32 cs 4 i.send_length ;
-    Cstruct.BE.set_uint32 cs 8 i.max_send_length ;
-    Cstruct.BE.set_uint32 cs 12 i.send_drops ;
-    Cstruct.BE.set_uint32 cs 16 i.mtu ;
-    Cstruct.BE.set_uint64 cs 20 i.baudrate ;
-    Cstruct.BE.set_uint64 cs 28 i.input_packets ;
-    Cstruct.BE.set_uint64 cs 36 i.input_errors ;
-    Cstruct.BE.set_uint64 cs 44 i.output_packets ;
-    Cstruct.BE.set_uint64 cs 52 i.output_errors ;
-    Cstruct.BE.set_uint64 cs 60 i.collisions ;
-    Cstruct.BE.set_uint64 cs 68 i.input_bytes ;
-    Cstruct.BE.set_uint64 cs 76 i.output_bytes ;
-    Cstruct.BE.set_uint64 cs 84 i.input_mcast ;
-    Cstruct.BE.set_uint64 cs 92 i.output_mcast ;
-    Cstruct.BE.set_uint64 cs 100 i.input_dropped ;
-    Cstruct.BE.set_uint64 cs 108 i.output_dropped ;
-    Cstruct.append name cs
-
-  let decode_ifdata buf =
-    decode_string buf >>= fun (name, l) ->
-    check_len buf (l + 116) >>= fun () ->
-    let cs = Cstruct.shift buf l in
-    let flags = Cstruct.BE.get_uint32 cs 0
-    and send_length = Cstruct.BE.get_uint32 cs 4
-    and max_send_length = Cstruct.BE.get_uint32 cs 8
-    and send_drops = Cstruct.BE.get_uint32 cs 12
-    and mtu = Cstruct.BE.get_uint32 cs 16
-    and baudrate = Cstruct.BE.get_uint64 cs 20
-    and input_packets = Cstruct.BE.get_uint64 cs 28
-    and input_errors = Cstruct.BE.get_uint64 cs 36
-    and output_packets = Cstruct.BE.get_uint64 cs 44
-    and output_errors = Cstruct.BE.get_uint64 cs 52
-    and collisions = Cstruct.BE.get_uint64 cs 60
-    and input_bytes = Cstruct.BE.get_uint64 cs 68
-    and output_bytes = Cstruct.BE.get_uint64 cs 76
-    and input_mcast = Cstruct.BE.get_uint64 cs 84
-    and output_mcast = Cstruct.BE.get_uint64 cs 92
-    and input_dropped = Cstruct.BE.get_uint64 cs 100
-    and output_dropped = Cstruct.BE.get_uint64 cs 108
-    in
-    Ok ({ name ; flags ; send_length ; max_send_length ; send_drops ; mtu ;
-          baudrate ; input_packets ; input_errors ; output_packets ;
-          output_errors ; collisions ; input_bytes ; output_bytes ; input_mcast ;
-          output_mcast ; input_dropped ; output_dropped },
-        l + 116)
-
-  let add id v nam pid taps =
-    let payload = Cstruct.append (encode_pid pid) (encode_strings taps) in
-    encode id v Add ~payload nam
-
-  let remove id v nam = encode id v Remove nam
-
-  let stat id v nam = encode id v Stat_request nam
-
-  let stat_reply id version payload =
-    let length = Cstruct.len payload
-    and tag = op_to_int Stat_reply
-    in
-    let r =
-      Cstruct.append (create_header { length ; id ; version ; tag }) payload
-    in
-    Cstruct.to_string r
-
-  let encode_int64 i =
-    let cs = Cstruct.create 8 in
-    Cstruct.BE.set_uint64 cs 0 i ;
-    cs
-
-  let decode_int64 ?(off = 0) cs =
-    check_len cs (8 + off) >>= fun () ->
-    Ok (Cstruct.BE.get_uint64 cs off)
-
-  let encode_vmm_stats xs =
-    encode_int (List.length xs) ::
-    List.flatten
-      (List.map (fun (k, v) -> [ fst (encode_string k) ; encode_int64 v ]) xs)
-
-  let decode_vmm_stats cs =
-    let rec go acc ctr buf =
-      if ctr = 0 then
-        Ok (List.rev acc, buf)
-      else
-        decode_string buf >>= fun (str, off) ->
-        decode_int64 ~off buf >>= fun v ->
-        go ((str, v) :: acc) (pred ctr) (Cstruct.shift buf (off + 8))
-    in
-    decode_int cs >>= fun stat_num ->
-    go [] stat_num (Cstruct.shift cs 8)
-
-  let encode_stats (ru, vmm, ifd) =
-    Cstruct.concat
-      (encode_rusage ru ::
-       encode_vmm_stats vmm @
-       encode_int (List.length ifd) :: List.map encode_ifdata ifd)
-
-  let decode_stats cs =
-    check_len cs 144 >>= fun () ->
-    let ru, rest = Cstruct.split cs 144 in
-    decode_rusage ru >>= fun ru ->
-    decode_vmm_stats rest >>= fun (vmm, rest) ->
-    let rec go acc ctr buf =
-      if ctr = 0 then
-        Ok (List.rev acc, buf)
-      else
-        decode_ifdata buf >>= fun (this, used) ->
-        go (this :: acc) (pred ctr) (Cstruct.shift buf used)
-    in
-    decode_int rest >>= fun num_if ->
-    go [] num_if (Cstruct.shift rest 8) >>= fun (ifs, _rest) ->
-    Ok (ru, vmm, ifs)
-
-  let decode_pid_taps data =
-    decode_pid data >>= fun pid ->
-    decode_strings (Cstruct.shift data 4) >>= fun taps ->
-    Ok (pid, taps)
-end
-
-module Log = struct
-  [%%cenum
-    type op =
-      | Data
-      | History
-    [@@uint16_t]
-  ]
-
-  let history id version ctx ts =
-    let tag = op_to_int History in
-    let nam, _ = encode_string ctx in
-    let payload = Cstruct.append nam (encode_ptime ts) in
-    let length = Cstruct.len payload in
-    let r =
-      Cstruct.append (create_header { length ; version ; id ; tag }) payload
-    in
-    Cstruct.to_string r
-
-  let encode_log_hdr ?(drop_context = false) hdr =
-    let ts = encode_ptime hdr.Log.ts
-    and ctx, _ = encode_string (if drop_context then "" else (string_of_id hdr.Log.context))
-    and name, _ = encode_string hdr.Log.name
-    in
-    Cstruct.concat [ ts ; ctx ; name ]
-
-  let decode_log_hdr cs =
-    decode_ptime cs >>= fun ts ->
-    let r = Cstruct.shift cs 16 in
-    decode_string r >>= fun (ctx, l) ->
-    let context = id_of_string ctx in
-    let r = Cstruct.shift r l in
-    decode_string r >>= fun (name, l) ->
-    Ok ({ Log.ts ; context ; name }, Cstruct.shift r l)
-
-  let encode_addr ip port =
-    let cs = Cstruct.create 6 in
-    Cstruct.BE.set_uint32 cs 0 (Ipaddr.V4.to_int32 ip) ;
-    Cstruct.BE.set_uint16 cs 4 port ;
-    cs
-
-  let decode_addr cs =
-    check_len cs 6 >>= fun () ->
-    let ip = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 cs 0)
-    and port = Cstruct.BE.get_uint16 cs 4
-    in
-    Ok (ip, port)
-
-  let encode_vm (pid, taps, block) =
-    let cs = encode_pid pid in
-    let bl, _ = encode_string (match block with None -> "" | Some x -> x) in
-    let taps = encode_strings taps in
-    Cstruct.concat [ cs ; bl ; taps ]
-
-  let decode_vm cs =
-    decode_pid cs >>= fun pid ->
-    let r = Cstruct.shift cs 4 in
-    decode_string r >>= fun (block, l) ->
-    let block = if block = "" then None else Some block in
-    decode_strings (Cstruct.shift r l) >>= fun taps ->
-    Ok (pid, taps, block)
-
-  let encode_pid_exit pid c =
-    let r, c = match c with
-      | `Exit n -> 0, n
-      | `Signal n -> 1, n
-      | `Stop n -> 2, n
-    in
-    let cs = Cstruct.create 1 in
-    Cstruct.set_uint8 cs 0 r ;
-    let pid = encode_pid pid
-    and code = encode_int c
-    in
-    Cstruct.concat [ pid ; cs ; code ]
-
-  let decode_pid_exit cs =
-    check_len cs 13 >>= fun () ->
-    decode_pid cs >>= fun pid ->
-    let r = Cstruct.get_uint8 cs 4 in
-    let code = Cstruct.shift cs 5 in
-    decode_int code >>= fun c ->
-    (match r with
-     | 0 -> Ok (`Exit c)
-     | 1 -> Ok (`Signal c)
-     | 2 -> Ok (`Stop c)
-     | _ -> Error (`Msg "couldn't parse exit status")) >>= fun r ->
-    Ok (pid, r)
-
-  let encode_block nam siz =
-    Cstruct.append (fst (encode_string nam)) (encode_int siz)
-
-  let decode_block cs =
-    decode_string cs >>= fun (nam, l) ->
-    check_len cs (l + 8) >>= fun () ->
-    decode_int ~off:l cs >>= fun siz ->
-    Ok (nam, siz)
-
-  let encode_delegate bridges bs =
-    Cstruct.append
-      (fst (encode_string (match bs with None -> "" | Some x -> x)))
-      (encode_strings bridges)
-
-  let decode_delegate buf =
-    decode_string buf >>= fun (bs, l) ->
-    let bs = if bs = "" then None else Some bs in
-    decode_strings (Cstruct.shift buf l) >>= fun bridges ->
-    Ok (bridges, bs)
-
-  let encode_event ev =
-    let tag, data = match ev with
-      | `Startup -> 0, empty
-      | `Login (ip, port) -> 1, encode_addr ip port
-      | `Logout (ip, port) -> 2, encode_addr ip port
-      | `VM_start vm -> 3, encode_vm vm
-      | `VM_stop (pid, c) -> 4, encode_pid_exit pid c
-      | `Block_create (nam, siz) -> 5, encode_block nam siz
-      | `Block_destroy nam -> 6, fst (encode_string nam)
-      | `Delegate (bridges, bs) -> 7, encode_delegate bridges bs
-    in
-    let cs = Cstruct.create 2 in
-    Cstruct.BE.set_uint16 cs 0 tag ;
-    Cstruct.append cs data
-
-  let decode_event cs =
-    check_len cs 2 >>= fun () ->
-    let data = Cstruct.(shift cs 2) in
-    match Cstruct.BE.get_uint16 cs 0 with
-     | 0 -> Ok `Startup
-     | 1 -> decode_addr data >>= fun addr -> Ok (`Login addr)
-     | 2 -> decode_addr data >>= fun addr -> Ok (`Logout addr)
-     | 3 -> decode_vm data >>= fun vm -> Ok (`VM_start vm)
-     | 4 -> decode_pid_exit data >>= fun ex -> Ok (`VM_stop ex)
-     | 5 -> decode_block data >>= fun bl -> Ok (`Block_create bl)
-     | 6 -> decode_string data >>= fun (nam, _) -> Ok (`Block_destroy nam)
-     | 7 -> decode_delegate data >>= fun d -> Ok (`Delegate d)
-     | x -> R.error_msgf "couldn't parse event type %d" x
-
-  let data id version hdr event =
-    let hdr = encode_log_hdr hdr
-    and ev = encode_event event
-    in
-    let payload = Cstruct.append hdr ev in
-    let length = Cstruct.len payload
-    and tag = op_to_int Data
-    in
-    let r =
-      Cstruct.append (create_header { length ; id ; version ; tag }) payload
-    in
-    Cstruct.to_string r
-end
-
-module Client = struct
-  let cmd_to_int = function
-    | Info -> 0
-    | Destroy_vm -> 1
-    | Create_block -> 2
-    | Destroy_block -> 3
-    | Statistics -> 4
-    | Attach -> 5
-    | Detach -> 6
-    | Log -> 7
-  and cmd_of_int = function
-    | 0 -> Some Info
-    | 1 -> Some Destroy_vm
-    | 2 -> Some Create_block
-    | 3 -> Some Destroy_block
-    | 4 -> Some Statistics
-    | 5 -> Some Attach
-    | 6 -> Some Detach
-    | 7 -> Some Log
-    | _ -> None
-
-  let console_msg_tag = 0xFFF0
-  let log_msg_tag = 0xFFF1
-  let stat_msg_tag = 0xFFF2
-  let info_msg_tag = 0xFFF3
-
-  let cmd ?arg it id version =
-    let pay, length = may_enc_str arg
-    and tag = cmd_to_int it
-    in
-    let hdr = create_header { length ; id ; version ; tag } in
-    Cstruct.(to_string (append hdr pay))
-
-  let log hdr event version =
-    let payload =
-      Cstruct.append
-        (Log.encode_log_hdr ~drop_context:true hdr)
-        (Log.encode_event event)
-    in
-    let length = Cstruct.len payload in
-    let r =
-      Cstruct.append
-        (create_header { length ; id = 0 ; version ; tag = log_msg_tag })
-        payload
-    in
-    Cstruct.to_string r
-
-  let stat data id version =
-    let length = String.length data in
-    let hdr = create_header { length ; id ; version ; tag = stat_msg_tag } in
-    Cstruct.to_string hdr ^ data
-
-  let console off name payload version =
-    let name = match List.rev (id_of_string name) with
-      | leaf::_ -> leaf
-      | [] -> "none"
-    in
-    let nam, l = encode_string name in
-    let payload, length =
-      let p' = Astring.String.drop ~max:off payload in
-      p', l + String.length p'
-    in
-    let hdr =
-      create_header { length ; id = 0 ; version ; tag = console_msg_tag }
-    in
-    Cstruct.(to_string (append hdr nam)) ^ payload
-
-  let encode_vm name vm =
-    let name, _ = encode_string name
-    and cs, _ = encode_string (Bos.Cmd.to_string vm.cmd)
-    and pid = encode_pid vm.pid
-    and taps = encode_strings vm.taps
-    in
-    let tapc = encode_int (Cstruct.len taps) in
-    let r = Cstruct.concat [ name ; cs ; pid ; tapc ; taps ] in
-    Cstruct.to_string r
-
-  let info data id version =
-    let length = String.length data in
-    let hdr = create_header { length ; id ; version ; tag = info_msg_tag } in
-    Cstruct.to_string hdr ^ data
-
-  let decode_vm cs =
-    decode_string cs >>= fun (name, l) ->
-    decode_string (Cstruct.shift cs l) >>= fun (cmd, l') ->
-    decode_pid (Cstruct.shift cs (l + l')) >>= fun pid ->
-    decode_int ~off:(l + l' + 4) cs >>= fun tapc ->
-    let taps = Cstruct.sub cs (l + l' + 12) tapc in
-    decode_strings taps >>= fun taps ->
-    Ok ((name, cmd, pid, taps), Cstruct.shift cs (l + l' + 12 + tapc))
-
-  let decode_info data =
-    let rec go acc buf =
-      if Cstruct.len buf = 0 then
-        Ok (List.rev acc)
-      else
-        decode_vm buf >>= fun (vm, rest) ->
-        go (vm :: acc) rest
-    in
-    go [] (Cstruct.of_string data)
-
-  let decode_stat data =
-    Stats.decode_stats (Cstruct.of_string data)
-
-  let decode_log data =
-    let cs = Cstruct.of_string data in
-    Log.decode_log_hdr cs >>= fun (hdr, rest) ->
-    Log.decode_event rest >>= fun event ->
-    Ok (hdr, event)
-
-  let decode_console data =
-    let cs = Cstruct.of_string data in
-    decode_string cs >>= fun (name, l) ->
-    decode_ptime (Cstruct.shift cs l) >>= fun ts ->
-    decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) ->
-    Ok (name, ts, line)
-end

stats/libvmm_stats_stubs.clib

@@ -1 +0,0 @@
-vmm_stats_stubs.o

stats/vmm_stats.ml

@@ -1,221 +0,0 @@
-(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
-
-open Astring
-open Rresult.R.Infix
-
-open Vmm_core
-
-external sysctl_rusage : int -> rusage = "vmmanage_sysctl_rusage"
-external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
-external sysctl_ifdata : int -> ifdata = "vmmanage_sysctl_ifdata"
-
-type vmctx
-
-external vmmapi_open : string -> vmctx = "vmmanage_vmmapi_open"
-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 = `WV1
-
-let descr = ref []
-
-type t = {
-  pid_nic : ((vmctx, int) result * (int * string) list) IM.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 ; vmid_pid = String.Map.empty }
-
-let rec wrap f arg =
-  try Some (f arg) with
-  | Unix.Unix_error (Unix.EINTR, _, _) -> wrap f arg
-  | e ->
-    Logs.err (fun m -> m "exception %s" (Printexc.to_string e)) ;
-    None
-
-let fill_descr ctx =
-  match !descr with
-  | [] ->
-    begin match wrap vmmapi_statnames ctx with
-      | None ->
-        Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ;
-        ()
-      | Some d ->
-        Logs.info (fun m -> m "descr are %a" pp_strings d) ;
-        descr := d
-    end
-  | ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds))
-
-let open_vmmapi ?(retries = 4) pid =
-  let name = "ukvm" ^ string_of_int pid in
-  if retries = 0 then begin
-    Logs.debug (fun m -> m "(ignored 0) vmmapi_open failed for %d" pid) ;
-    Error 0
-  end else
-    match wrap vmmapi_open name with
-    | None ->
-      let left = max 0 (pred retries) in
-      Logs.warn (fun m -> m "(ignored, %d attempts left) vmmapi_open failed for %d" left pid) ;
-      Error left
-    | Some vmctx ->
-      Logs.info (fun m -> m "vmmapi_open succeeded for %d" pid) ;
-      fill_descr vmctx ;
-      Ok vmctx
-
-let try_open_vmmapi pid_nic =
-  IM.fold (fun pid (vmctx, nics) fresh ->
-      let vmctx =
-        match vmctx with
-        | Ok vmctx -> Ok vmctx
-        | Error retries -> open_vmmapi ~retries pid
-      in
-      IM.add pid (vmctx, nics) fresh)
-    pid_nic IM.empty
-
-let gather pid vmctx nics =
-  wrap sysctl_rusage pid,
-  (match vmctx with
-   | Error _ -> None
-   | Ok 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 ->
-        Logs.debug (fun m -> m "adding ifdata for %s" nname) ;
-        String.Map.add data.name data ifd)
-    String.Map.empty nics
-
-let tick t =
-  Logs.debug (fun m -> m "tick with %d vms" (IM.cardinal t.pid_nic)) ;
-  let pid_rusage, pid_vmmapi, nic_ifdata =
-    IM.fold (fun pid (vmctx, nics) (rus, vmms, ifds) ->
-        let ru, vmm, ifd = gather pid vmctx nics in
-        (match ru with
-         | None ->
-           Logs.warn (fun m -> m "failed to get rusage for %d" pid) ;
-           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 ->
-           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
-  let pid_nic = try_open_vmmapi t.pid_nic in
-  { t with pid_rusage ; pid_vmmapi ; nic_ifdata ; pid_nic }
-
-let add_pid t vmid pid nics =
-  match wrap sysctl_ifcount () with
-  | None ->
-    Logs.err (fun m -> m "sysctl ifcount failed for %d %a" pid pp_strings nics) ;
-    Error (`Msg "sysctl ifcount failed")
-  | Some max_nic ->
-    let rec go cnt acc id =
-      if id > 0 && cnt > 0 then
-        match wrap sysctl_ifdata id with
-        | Some ifd when List.mem ifd.name nics ->
-          go (pred cnt) ((id, ifd.name) :: acc) (pred id)
-        | _ -> go cnt acc (pred id)
-      else
-        List.rev acc
-    in
-    Ok (go (List.length nics) [] max_nic) >>= fun nic_ids ->
-    let vmctx = open_vmmapi pid in
-    Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics
-                  (match vmctx with Error _ -> false | Ok _ -> true)) ;
-    let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic
-    and vmid_pid = String.Map.add vmid pid t.vmid_pid
-    in
-    Ok { t with pid_nic ; vmid_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
-      and ru = IM.find pid t.pid_rusage
-      and vmm =
-        try IM.find pid t.pid_vmmapi with
-        | Not_found ->
-          Logs.err (fun m -> m "failed to find vmm stats for %d" pid);
-          []
-      in
-      match
-        List.fold_left (fun acc nic ->
-            match String.Map.find nic t.nic_ifdata, acc with
-            | None, _ -> None
-            | _, None -> None
-            | Some ifd, Some acc -> Some (ifd :: acc))
-          (Some []) (snd (List.split nics))
-      with
-      | None -> Error (`Msg "failed to find interface statistics")
-      | Some ifd -> Ok (ru, vmm, ifd)
-    with
-    | _ -> Error (`Msg "failed to find resource usage")
-
-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
-       | Ok vmctx, _ -> ignore (wrap vmmapi_close vmctx)
-       | Error _, _ -> ()
-     with
-       _ -> ()) ;
-    let pid_nic = IM.remove pid t.pid_nic
-    and vmid_pid = String.Map.remove vmid t.vmid_pid
-    in
-    { t with pid_nic ; vmid_pid }
-
-let remove_vmids t vmids =
-  List.fold_left remove_vmid t vmids
-
-let handle t hdr buf =
-  let open Vmm_wire in
-  let open Vmm_wire.Stats in
-  let cs = Cstruct.of_string buf in
-  let r =
-    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 (Cstruct.shift cs off) >>= fun (pid, taps) ->
-        add_pid t name pid taps >>= fun t ->
-        Ok (t, `Add name, success ~msg:"added" hdr.id my_version)
-      | Some Remove ->
-        let t = remove_vmid t name in
-        Ok (t, `Remove name, success ~msg:"removed" hdr.id my_version)
-      | Some Stat_request ->
-        stats t name >>= fun s ->
-        Ok (t, `None, stat_reply hdr.id my_version (encode_stats s))
-      | _ -> Error (`Msg "unknown command")
-  in
-  match r with
-  | Ok (t, action, out) -> t, action, out
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "error while processing %s" msg) ;
-    t, `None, fail ~msg hdr.id my_version