initial

.gitignore

@@ -0,0 +1,2 @@
+_build
+vmm.install

.merlin

@@ -0,0 +1,9 @@
+S src
+S stats
+S app
+S provision
+
+B _build/**
+
+PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration
+PKG ptime ptime.clock.os ipaddr.unix

README.md

@@ -0,0 +1,153 @@
+# Managing virtual machines
+
+A set of binaries to manage, provision, and deploy virtual machine images.  This
+is very much work in progress, don't expect anything stable.
+
+Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
+and an overview.
+
+The implementation uses explicit errors (no exceptions), and make mostly use of
+the (blocking!) Bos library for operating system commands.  A thin layer of Lwt
+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.
+
+It requires some pinned packages:
+- `asn1-combinators https://github.com/hannesm/ocaml-asn-combinators.git#enum`
+- `x509 https://github.com/hannesm/ocaml-x509.git#crl`
+- `tls https://github.com/hannesm/ocaml-tls.git#changes`
+- on FreeBSD, `solo5-kernel-ukvm https://github.com/solo5/solo5.git`
+
+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
+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
+to be executed on.  Of course you can conflate everything into a single
+development system or your server, all up to you and your security scenario.
+
+Exact file transfer operations between these machines is not in scope of this
+document, but kept abstract as `COPY`.  Some commands require superuser
+privileges (use `sudo`, `su`, or `doas`), I prefixed them with `#`.
+
+File endings used in this document:
+- `.db` for CA databases
+- `.pem` for (PEM-encoded) signed certificates
+- `.key` for (PEM-encoded) private keys
+- `.req` for (PEM-encoded) certificate signing requests
+
+## Setup a certificate authority
+
+The first step is to setup a certificate authority (private key and CA
+certificate).  The CA private key can sign and revoke everything, you should
+better keep it in a safe place (air-gapped machine etc.) - not on the server!
+
+```
+CA> vmm_gen_ca ca ca.db [--days 3650] [--server "server"] [--server-days 365]
+```
+
+This generated five files:
+- `ca.key` which is the CA private key
+- `cacert.pem` which is the CA certificate
+- `ca.db` which contains a map between serial number and name of issued certificates
+- `server.pem` is the server certificate
+- `server.key` is the private key of the server
+
+## Server setup
+
+If you have installed this package on your development machine, follow some more
+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 build
+DEV> mv ukvm-bin /tmp/ukvm-bin.none
+DEV> cd ../device-usage/network
+DEV> mirage configure -t ukvm
+DEV> mirage build
+DEV> mv ukvm-bin /tmp/ukvm-bin.net
+DEV> cd ../../..
+DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:
+DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:
+```
+
+```
+SRV> vmm_console -vv cons.sock &
+SRV> vmm_log -vv log.out log.sock &
+SRV> vmm_stats_lwt -vv stat.sock & #optional
+SRV# vmmd -vv . cacert.pem server.pem server.key
+```
+
+Some setup for network interfaces is needed, depending on your operating system.
+You can also add NAT to allow your virtual machines to talk to the outside
+world, or add your external interface to the bridge directly, or just keep your
+VMs local.
+
+```
+# FreeBSD
+SRV# ifconfig bridge create
+SRV# ifconfig bridge0 name ext
+SRV# sysctl net.link.tap.up_on_open=1
+# Linux
+SRV# brctl addbr ext
+```
+
+## Provision our first virtual machine
+
+We will delegate some resource to a certificate and key we keep on our
+development machine.
+
+```
+DEV> vmm_req_delegation dev 2 1024 --cpu 1 --bridge ext/10.0.0.2/10.0.0.5/10.0.0.1/24
+DEV> COPY dev.req CA:
+```
+
+This produced two files, dev.req and dev.key.  Keep the key in a safe place!
+
+```
+CA> vmm_sign ca.db cacert.pem ca.key dev.req [--days 10]
+CA> COPY dev.pem DEV:
+```
+
+Now, our DEV machine can use its delegation certificate for issuing other
+certificates.  We'll create a certificate for interactive use, and one
+containing the hello unikernel.
+
+```
+DEV> vmm_req_permissions admin --permission all
+DEV> vmm_sign dev.db dev.pem dev.key admin.req
+```
+
+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 512 1
+DEV> vmm_sign dev.db dev.pem dev.key hello.req
+```
+
+This produced three more files, `hello.{req,key,pem}` and modified `dev.db`.
+
+To actually deploy anything, the server needs the chain (i.e. the vm certificate
+and the delegation certificate).  Our client needs the main CA certificate to
+authenticate the server itself.
+
+```
+CA> COPY cacert.pem DEV:
+DEV> cat admin.pem dev.pem > admin.bundle
+DEV> cat hello.pem dev.pem > hello.bundle
+```
+
+And deploying (watch the output of the processes started on the server above!):
+
+```
+DEV> vmm_client cacert.pem hello.bundle hello.key SRV:1025
+DEV> vmm_client cacert.pem admin.bundle hello.key SRV:1025 --db dev.db
+```
+
+Commands are at the moment `info`, `statistics`, `destroy`, `attach`, `detach`,
+and `log`.

_tags

@@ -0,0 +1,17 @@
+true : bin_annot, safe_string, principal
+true : warn(+A-44)
+true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration)
+"src" : include
+
+<src/vmm_wire.{ml,mli}>: package(cstruct.ppx)
+<src/vmm_asn.{ml,mli}>: package(asn1-combinators)
+<src/vmm_lwt.{ml,mli}>: package(lwt)
+<src/vmm_tls.{ml,mli}>: package(lwt tls.lwt)
+
+<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix)
+<app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
+<app/vmmd.{ml,native,byte}>: package(tls.lwt)
+
+<provision/*>: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt)
+
+<stats/vmm_stats_lwt.{ml,native,byte}>: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt)

app/vmm_client.ml

@@ -0,0 +1,189 @@
+(* (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, ifd) ->
+        Logs.app (fun m -> m "statistics: %a %a"
+                      pp_rusage ru 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 =
+  Lwt.catch (fun () ->
+      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
+      | Ok (hdr, data) ->
+        Logs.debug (fun m -> m "read from tls 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 (Cstruct.of_string data)) ;
+        process db hdr data ;
+        read_tls_write_cons db t)
+    (fun _ -> Lwt.return_unit)
+
+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 >>= fun () ->
+        Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
+        read_cons_write_tls db t)
+    (fun _ -> 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
+      Vmm_tls.read_tls t >|= function
+      | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg)
+      | Ok (hdr, data) -> process db hdr data
+    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

@@ -0,0 +1,179 @@
+(* (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.Set.empty
+
+let read_console s 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) ;
+        (if String.Set.mem name !active then
+           Vmm_lwt.write_raw s (data my_version name t line)
+         else
+           Lwt.return_unit) >>= fun () ->
+        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.(v (Filename.get_temp_dir_name ()) / 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 s 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 s name ring f) ;
+    Ok "reading"
+  | None ->
+    Error (`Msg "opening")
+
+let attach 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.Set.add name !active ;
+    Lwt.return (Ok "attached")
+
+let detach name =
+  active := String.Set.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)) 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 ()
+    | Ok (hdr, data) ->
+      (if not (version_eq hdr.version my_version) then
+         Lwt.return (Error (`Msg "ignoring data with bad version"))
+       else
+         match Console.int_to_op hdr.tag with
+         | Some Add ->
+           (match decode_str data with
+            | Error e -> Lwt.return (Error e)
+            | Ok (name, _) -> add_fifo s name)
+         | Some Attach ->
+           (match decode_str data with
+            | Error e -> Lwt.return (Error e)
+            | Ok (name, _) -> attach name)
+         | Some Detach ->
+           (match decode_str data with
+            | Error e -> Lwt.return (Error e)
+            | Ok (name, _) -> detach name)
+         | Some History ->
+           (match decode_str data with
+             | Error e -> Lwt.return (Error e)
+             | Ok (name, off) -> 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)) >>= fun () ->
+      loop ()
+  in
+  loop ()
+
+let jump _ file =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+     Lwt_unix.(Versioned.bind_2 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 onto" in
+  Arg.(value & pos 0 string "" & info [] ~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

@@ -0,0 +1,127 @@
+(* (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 handle fd ring s addr () =
+  Logs.info (fun m -> m "handling connection") ;
+  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 ()
+    | Ok (hdr, data) ->
+      (if not (version_eq hdr.version my_version) then
+         Lwt.return (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 _ -> ()) ;
+           write_complete fd data >>= fun () ->
+           Lwt.return (Ok None)
+         | Some History ->
+           begin match decode_str data with
+             | Error e -> Lwt.return (Error e)
+             | Ok (str, off) -> match decode_ts ~off data with
+               | Error e -> Lwt.return (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 *)
+                 Lwt_list.iter_s (fun 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
+                     Vmm_lwt.write_raw s (Cstruct.to_string hdr ^ x))
+                   (List.rev res) >>= fun () ->
+                 Lwt.return (Ok None)
+           end
+         | _ ->
+           Logs.err (fun m -> m "didn't understand log command %d" hdr.tag) ;
+           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: %s" msg) ;
+            Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= fun () ->
+    loop ()
+  in
+  Lwt.catch loop (fun e -> 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 ->
+     let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+     Lwt_unix.(Versioned.bind_2 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 onto" in
+  Arg.(required & pos 1 (some string) None & info [] ~doc)
+
+let file =
+  let doc = "File to write to" in
+  Arg.(required & pos 0 (some string) None & info [] ~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.ml

@@ -0,0 +1,244 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+let write_tls state t data =
+  Lwt.catch (fun () -> Vmm_tls.write_tls (fst t) data)
+    (fun e ->
+       let state', out = Vmm_engine.handle_disconnect !state t in
+       state := state' ;
+       Lwt_list.iter_s (fun (s, data) -> Vmm_lwt.write_raw s data) out >>= fun () ->
+       raise e)
+
+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) -> Vmm_lwt.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 = Unix.gettimeofday () 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))) ;
+       Lwt.fail e) >>= fun () ->
+  (match Tls_lwt.Unix.epoch (fst t) with
+   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
+   | `Error -> 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 () ->
+    (match next with
+     | `Create cont ->
+       (match cont !state t with
+        | Ok (state', outs, vm) ->
+          state := state' ;
+          process state outs >>= fun () ->
+          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
+              state := state' ;
+              process state outs) ;
+          Lwt.return_unit
+        | 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) ]) >>= fun () ->
+       Tls_lwt.Unix.close (fst t)
+     | `Loop (prefix, perms) ->
+       let rec loop () =
+         Vmm_tls.read_tls (fst t) >>= function
+         | Error (`Msg msg) ->
+           Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ;
+           loop ()
+         | Ok (hdr, buf) ->
+           let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in
+           state := state' ;
+           process state out >>= fun () ->
+           loop ()
+       in
+       Lwt.catch loop (fun e ->
+           let state', cons = Vmm_engine.handle_disconnect !state t in
+           state := state' ;
+           Lwt_list.iter_s (fun (s, data) -> Vmm_lwt.write_raw s data) cons >>= fun () ->
+           raise e)
+     | `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))
+  | 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)
+
+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 ;
+  Versioned.bind_2 s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
+  listen s 10 ;
+  Lwt.return s
+
+let init_exception () =
+  Lwt.async_exception_hook := (function
+      | Tls_lwt.Tls_failure a ->
+        Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a))
+      | exn ->
+        Logs.err (fun m -> m "exception: %s" (Printexc.to_string exn)))
+
+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
+  | 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 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
+  | 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
+  | 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 jump _ dir cacert cert priv_key =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    (init_exception () ;
+     let d = Fpath.v dir in
+     let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+     Lwt_unix.set_close_on_exec c ;
+     Lwt_unix.(connect c (ADDR_UNIX Fpath.(to_string (d / "cons" + "sock")))) >>= fun () ->
+     Lwt.catch (fun () ->
+         let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+         Lwt_unix.set_close_on_exec s ;
+         Lwt_unix.(connect s (ADDR_UNIX Fpath.(to_string (d / "stat" + "sock")))) >|= fun () ->
+         Some s)
+       (function
+         | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return None
+         | e -> Lwt.fail e) >>= fun s ->
+     let l = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+     Lwt_unix.set_close_on_exec l ;
+     Lwt_unix.(connect l (ADDR_UNIX Fpath.(to_string (d / "log" + "sock")))) >>= fun () ->
+     server_socket 1025 >>= 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
+     (match Vmm_engine.init d 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) ;
+     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 () -> handle ca state t) ;
+           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 ())
+
+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 wdir =
+  let doc = "Working directory (unix domain sockets, etc.)" in
+  Arg.(required & pos 0 (some dir) None & info [] ~doc)
+
+let cacert =
+  let doc = "CA certificate" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let cert =
+  let doc = "Certificate" in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let key =
+  let doc = "Private key" in
+  Arg.(required & pos 3 (some file) None & info [] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ wdir $ cacert $ cert $ key)),
+  Term.info "vmmd" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

myocamlbuild.ml

@@ -0,0 +1,18 @@
+open Ocamlbuild_plugin
+
+let to_opt = List.fold_left (fun acc x -> [A "-ccopt"; A x] @ acc) []
+let ccopt = to_opt [ "-O3" ; "-Wall" ]
+
+let () =
+  dispatch begin function
+    | After_rules ->
+      flag ["c"; "compile"] (S ccopt) ;
+      flag ["link"; "library"; "ocaml"; "byte"; "use_vmm_stats"]
+        (S ([A "-dllib"; A "-lvmm_stats_stubs"]));
+      flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"]
+        (S ([A "-cclib"; A "-lvmm_stats_stubs"]));
+      flag ["link"; "ocaml"; "link_vmm_stats"] (A "stats/libvmm_stats_stubs.a");
+      dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
+      dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
+    | _ -> ()
+  end

opam

@@ -0,0 +1,25 @@
+opam-version: "1.2"
+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"]
+
+depends: [
+  "ocamlfind" {build}
+  "ocamlbuild" {build}
+  "topkg" {build}
+  "lwt"
+  "ipaddr" {>= "2.2.0"}
+  "hex"
+  "cstruct"
+  "ppx_cstruct" {build}
+  "logs" "rresult" "bos" "ptime" "cmdliner" "fmt" "astring"
+  "x509" "tls" "nocrypto" "asn1-combinators"
+  "duration"
+]
+
+build: [
+  [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
+]

pkg/META

@@ -0,0 +1,7 @@
+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"
+archive(byte) = "vmm.cma"
+archive(native) = "vmm.cmxa"
+plugin(byte) = "vmm.cma"
+plugin(native) = "vmm.cmxs"

pkg/pkg.ml

@@ -0,0 +1,21 @@
+#!/usr/bin/env ocaml
+#use "topfind"
+#require "topkg"
+open Topkg
+
+let () =
+  Pkg.describe "vmm" @@ 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" ;
+  ]

provision/vmm_gen_ca.ml

@@ -0,0 +1,50 @@
+(* (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_provision.ml

@@ -0,0 +1,135 @@
+(* (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 asn1_of_unix ts =
+  let tm = Unix.gmtime ts in
+  { Asn.Time.date = Unix.(tm.tm_year + 1900, (tm.tm_mon + 1), tm.tm_mday) ;
+    time = Unix.(tm.tm_hour, tm.tm_min, tm.tm_sec, 0.) ;
+    tz = None }
+
+let timestamps validity =
+  let valid = Duration.to_f validity
+  and now = Unix.time ()
+  in
+  let start = asn1_of_unix now
+  and expire = asn1_of_unix (now +. valid)
+  in
+  (start, expire)
+
+let rec safe f arg =
+  try Ok (f arg) with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> safe f arg
+  | Unix.Unix_error (e, _, _) -> Error (`Msg (Unix.error_message e))
+
+(* TODO: is this useful elsewhere? *)
+let append name data =
+  let open Rresult.R.Infix in
+  let buf = Bytes.unsafe_of_string data in
+  let nam = Fpath.to_string name in
+  safe Unix.(openfile nam [ O_APPEND ; O_CREAT ; O_WRONLY ]) 0o644 >>= fun fd ->
+  let len = String.length data in
+  let rec go off =
+    let l = len - off in
+    safe (Unix.write fd buf off) l >>= fun w ->
+    if l = w then Ok ()
+    else go (w + off)
+  in
+  go 0 >>= fun () ->
+  safe Unix.close fd
+
+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 sign ?dbname ?certname extensions issuer key csr delta =
+  let open Rresult.R.Infix in
+  (match certname with
+   | Some x -> Ok x
+   | None ->
+     (try Ok (List.find (function `CN _ -> true | _ -> false) (X509.CA.info csr).X509.CA.subject)
+      with Not_found -> Error (`Msg "unable to discover certificate name")) >>= fun nam ->
+     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 ->
+  let valid_from, valid_until = timestamps delta in
+  (match dbname with
+   | None -> Ok extensions (* evil hack to avoid issuer + public key for CA cert *)
+   | Some _ ->
+     match key with
+     | `RSA priv ->
+       let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in
+       Ok (extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub)) >>= fun extensions ->
+  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 ->
+     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)
+
+let priv_key ?(bits = 2048) fn name =
+  let open Rresult.R.Infix in
+  match fn with
+  | None ->
+    let priv = `RSA (Nocrypto.Rsa.generate bits) in
+    Bos.OS.File.write ~mode:0o400 Fpath.(v name + "key") (Cstruct.to_string (X509.Encoding.Pem.Private_key.to_pem_cstruct1 priv)) >>= fun () ->
+    Ok priv
+  | Some fn ->
+    Bos.OS.File.read (Fpath.v fn) >>= fun s ->
+    Ok (X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string s))
+
+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)
+
+let cacert =
+  let doc = "cacert" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let key =
+  let doc = "Private key" in
+  Arg.(value & opt (some file) None & info [ "key" ] ~doc)
+
+let db =
+  let doc = "Database" in
+  Arg.(required & pos 0 (some string) None & info [] ~doc)
+
+let mem =
+  let doc = "Memory to provision" in
+  Arg.(required & pos 2 (some int) None & info [] ~doc)

provision/vmm_req_delegation.ml

@@ -0,0 +1,85 @@
+(* (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 bridges)) ]
+  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

@@ -0,0 +1,46 @@
+(* (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

@@ -0,0 +1,70 @@
+(* (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 =
+  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)) ]
+  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_to_cstruct (`Ukvm_amd64, image))) ;
+      (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ `Image ])) ;
+    ] @ 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 =
+  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 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 cmd =
+  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net)),
+  Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_revoke.ml

@@ -0,0 +1,78 @@
+(* (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 = asn1_of_unix (Unix.time ()) 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

@@ -0,0 +1,285 @@
+(* (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
+        let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Image ]) :: 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

@@ -0,0 +1,210 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Vmm_core
+
+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.bit_string_flags [
+    0, `All ;
+    1, `Info ;
+    2, `Image ;
+    3, `Block ;
+    4, `Statistics ;
+    5, `Console ;
+    6, `Log ;
+    7, `Crl ;
+  ]
+
+let decode_strict codec cs =
+  try
+    let (a, cs) = Asn.decode_exn codec cs in
+    if Cstruct.len cs = 0 then
+      Ok a
+    else
+      Error (`Msg "trailing bytes")
+  with
+  | e -> Error (`Msg (Printexc.to_string e))
+
+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.int
+let ints_of_cstruct, ints_to_cstruct = projections_of Asn.(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)
+  in
+  Asn.map f g Asn.octet_string
+
+let bridge =
+  let f = function
+    | `C1 nam -> `Internal nam
+    | `C2 (nam, s, e, r, n) -> `External (nam, s, e, r, n)
+  and g = function
+    | `Internal nam -> `C1 nam
+    | `External (nam, s, e, r, n) -> `C2 (nam, s, e, r, n)
+  in
+  Asn.map f g @@
+  Asn.(choice2
+         (explicit 0 utf8_string)
+         (explicit 1 (sequence5
+                        (required ~label:"name" utf8_string)
+                        (required ~label:"start" ipv4)
+                        (required ~label:"end" ipv4)
+                        (required ~label:"router" ipv4)
+                        (required ~label:"netmask" int))))
+
+let bridges_of_cstruct, bridges_to_cstruct =
+  projections_of (Asn.sequence_of bridge)
+
+let strings_of_cstruct, strings_to_cstruct =
+  projections_of Asn.(sequence_of utf8_string)
+
+let string_of_cstruct, string_to_cstruct = projections_of Asn.utf8_string
+
+let image =
+  let f = function
+    | `C1 x -> `Ukvm_amd64, x
+    | `C2 x -> `Ukvm_arm64, x
+  and g = function
+    | `Ukvm_amd64, x -> `C1 x
+    | `Ukvm_arm64, x -> `C2 x
+  in
+  Asn.map f g @@
+  Asn.(choice2
+         (explicit 0 octet_string)
+         (explicit 1 octet_string))
+
+let image_of_cstruct, image_to_cstruct = projections_of image
+
+let permissions_of_cstruct, permissions_to_cstruct = projections_of perms
+
+open Rresult.R.Infix
+
+let req label cert oid f =
+  match X509.Extension.unsupported cert oid with
+  | None -> R.error_msgf "OID %s not present (%s)" label (Asn.OID.to_string 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 bridges = match bridges with
+    | None -> String.Map.empty
+    | Some 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 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
+  in
+  req "crl" cert Oid.crl crl
+
+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 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 ; memory ; block_device ; network ; vmimage ; argv }
+
+let permissions_of_cert version cert =
+  version_of_cert version cert >>= fun () ->
+  req "permissions" cert Oid.permissions permissions_of_cstruct

src/vmm_asn.mli

@@ -0,0 +1,161 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(** ASN.1 encoding of resources and configuration *)
+
+(** Object Identifiers *)
+
+module Oid : sig
+
+  (** {1 Object identifiers} *)
+
+  (** OIDs in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.42) *)
+
+  (** [version] specifies an [INTEGER] describing the version. *)
+  val version : Asn.OID.t
+
+  (** {2 OIDs used in delegation certificates} *)
+
+  (** [vms] is an [INTEGER] denoting the number of virtual machines. *)
+  val vms : Asn.OID.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
+
+  (** [block] is an [INTEGER] denoting the size of block storage available for
+      this delegation in MB. *)
+  val block : Asn.OID.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

src/vmm_commands.ml

@@ -0,0 +1,186 @@
+(* (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) 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 ; Unix.O_APPEND]
+
+let rec waitpid flags pid =
+  try Unix.waitpid flags pid with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> waitpid flags pid
+
+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 e -> ()
+
+(* own code starts here
+   (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Vmm_core
+
+let rec mkfifo name =
+  try Unix.mkfifo name 0o640 with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
+
+let tmpfile vm suffix =
+  let name = filename vm in
+  Fpath.(v (Filename.get_temp_dir_name ()) / name + suffix)
+
+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 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 prepare vm =
+  let vmimage = tmpfile vm "img" in
+  (match vm.vmimage with
+   | `Ukvm_amd64, blob -> Ok blob
+   | _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image ->
+  Bos.OS.File.write vmimage (Cstruct.to_string image) >>= fun () ->
+  let fifo = tmpfile vm "fifo" 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 (Fpath.to_string 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 ->
+  Ok (fifo, vmimage, List.rev taps)
+
+let shutdown vm =
+  List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps >>= fun () ->
+  let fifo = tmpfile vm.config "fifo" in
+  Bos.OS.File.delete fifo >>= fun () ->
+  let vmimage = tmpfile vm.config "img" in
+  Bos.OS.File.delete vmimage
+
+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 dir vm fifo vmimage taps =
+  (* TODO: --net-mac=xx *)
+  let net = List.map (fun t -> "--net=" ^ t) taps in
+  let argv = match vm.argv with None -> [] | Some xs -> xs in
+  (match taps with
+   | [] -> Ok Fpath.(dir / "ukvm-bin.none")
+   | [_] -> Ok Fpath.(dir / "ukvm-bin.net")
+   | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
+  cpuset vm.cpuid >>= fun cpuset ->
+  let cmd = Bos.Cmd.(of_list cpuset % p bin %% of_list net % "--" % p vmimage %% 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
+  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) ;
+    Ok { config = vm ; 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 9

src/vmm_commands.mli

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

src/vmm_core.ml

@@ -0,0 +1,376 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+open Rresult.R.Infix
+
+module I = struct
+  type t = int
+  let compare : int -> int -> int = compare
+end
+
+module IS = Set.Make(I)
+module IM = Map.Make(I)
+
+type permission =
+  [ `All | `Info | `Image | `Block | `Statistics | `Console | `Log | `Crl ]
+
+let pp_permission ppf = function
+  | `All -> Fmt.pf ppf "all"
+  | `Info -> Fmt.pf ppf "info"
+  | `Image -> Fmt.pf ppf "image"
+  | `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"
+
+let permission_of_string = function
+  | x when x = "all" -> Some `All
+  | x when x = "info" -> Some `Info
+  | x when x = "image" -> Some `Image
+  | 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
+  | _ -> None
+
+type cmd =
+  [ `Info
+  | `Destroy_image
+  | `Create_block
+  | `Destroy_block
+  | `Statistics
+  | `Attach
+  | `Detach
+  | `Log
+  ]
+
+let pp_cmd ppf = function
+  | `Info -> Fmt.pf ppf "info"
+  | `Destroy_image -> 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_image
+  | 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_image -> `Image
+    | `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 ]
+
+let pp_vmtype ppf = function
+  | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64"
+  | `Ukvm_arm64 -> Fmt.pf ppf "ukvm-arm64"
+
+type id = string list
+
+let string_of_id ids = String.concat ~sep:"." ids
+
+let id_of_string str = String.cuts ~sep:"." str
+
+let drop_super ~super ~sub =
+  let rec go sup sub = match sup, sub with
+    | [], xs -> Some (List.rev xs)
+    | _, [] -> None
+    | x::xs, z::zs -> if String.equal x z then go xs zs else None
+  in
+  go (List.rev super) (List.rev sub)
+
+let is_sub_id ~super ~sub =
+  match drop_super ~super ~sub with None -> false | Some _ -> true
+
+let pp_id ppf ids =
+  Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids)
+
+let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
+
+type bridge = [
+  | `Internal of string
+  | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
+]
+
+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 = {
+  vms : int ;
+  cpuids : IS.t ;
+  memory : int ;
+  block : int option ;
+  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"
+    res.vms pp_is res.cpuids res.memory
+    Fmt.(option ~none:(unit "no") int) res.block
+    Fmt.(list ~sep:(unit ", ") pp_bridge)
+    (List.map snd (String.Map.bindings res.bridges))
+
+let sub_bridges super sub =
+  String.Map.for_all (fun idx v ->
+      match String.Map.find idx super, v with
+      | None, _ -> false
+      | Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0
+      | Some (`External (nam, supf, supl, gw, nm)),
+        `External (nam', subf, subl, gw', nm') ->
+        String.compare nam nam' = 0 && nm = nm' &&
+        Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0
+      | _ -> false)
+    sub
+
+let sub_block super sub =
+  match super, sub with
+   | None, None -> true
+   | Some _, None -> true
+   | Some x, Some y -> x >= y
+   | None, Some _ -> false
+
+let sub_cpu super sub = IS.subset sub super
+
+let is_sub ~super ~sub =
+  sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids &&
+  sub.memory <= super.memory &&
+  sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
+
+type vm_config = {
+  prefix : id ;
+  vname : string ;
+  cpuid : int ;
+  memory : int ;
+  block_device : string option ;
+  network : string list ;
+  vmimage : vmtype * Cstruct.t ;
+  argv : string list option ;
+}
+
+let fullname vm = vm.prefix @ [ vm.vname ]
+
+let filename 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 =
+  Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
+    vm.vname vm.cpuid vm.memory
+    Fmt.(option ~none:(unit "no") string) vm.block_device
+    Fmt.(list ~sep:(unit ", ") string) vm.network
+    pp_image vm.vmimage
+    Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv
+
+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)  =
+  res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
+  vm.memory <= res.memory &&
+  good_bridge vm.network res.bridges
+
+let check_policies vm res =
+  let rec climb = function
+    | super :: sub :: xs ->
+      if is_sub ~super ~sub then climb (sub :: xs)
+      else Error (`Msg "policy violation")
+    | [x] -> Ok x
+    | [] -> Error (`Msg "empty resource list")
+  in
+  climb res >>= fun res ->
+  if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy")
+
+type vm = {
+  config : vm_config ;
+  cmd : Bos.Cmd.t ;
+  pid : int ;
+  taps : string list ;
+  stdout : Unix.file_descr (* ringbuffer thingy *)
+}
+
+let pp_vm ppf vm =
+  Fmt.pf ppf "pid %d@ taps %a cmdline %a"
+    vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps
+    Bos.Cmd.pp vm.cmd
+
+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)
+
+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 ;
+}
+
+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 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 ;
+}
+
+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
+
+module Log = struct
+  type hdr = {
+    ts : Ptime.t ;
+    context : id ;
+    name : string ;
+  }
+
+  let pp_hdr db ppf 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 *)
+    ]
+
+  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 %d" pid s 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 *)
+
+  type msg = hdr * event
+
+  let pp db ppf (hdr, event) =
+    Fmt.pf ppf "%a %a" (pp_hdr db) hdr pp_event event
+end

src/vmm_engine.ml

@@ -0,0 +1,507 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+open Vmm_core
+
+open Rresult
+open R.Infix
+
+type ('a, 'b) t = {
+  dir : Fpath.t ;
+  cmp : 'b -> 'b -> bool ;
+  console_socket : 'a ;
+  console_counter : int ;
+  console_requests : (('a, 'b) t -> ('a, 'b) 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) 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 ; *)
+  bridges : String.Set.t String.Map.t ;
+  (* TODO: used block devices (since each may only be active once) *)
+  resources : Vmm_resources.t ;
+  crls : X509.CRL.c list ;
+}
+
+let init dir cmp console_socket stats_socket log_socket =
+  (* error hard on permission denied etc. *)
+  let crls = Fpath.(dir / "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 [])
+    Fpath.(dir / "crls") >>= fun crls ->
+  crls >>= fun crls ->
+  Ok {
+    dir ; cmp ;
+    console_socket ; console_counter = 1 ; console_requests = IM.empty ;
+    console_attached = String.Map.empty ; console_version = `WV0 ;
+    stats_socket ; stats_counter = 1 ; stats_requests = IM.empty ;
+    stats_version = `WV0 ;
+    log_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
+    log_version = `WV0 ; log_requests = IM.empty ;
+    client_version = `WV0 ;
+    bridges = String.Map.empty ;
+    resources = Vmm_resources.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 prefix chain cert =
+  Logs.debug (fun m -> m "starting with vms %a" Vmm_resources.pp t.resources) ;
+  (* convert certificate to vm_config *)
+  Vmm_asn.vm_of_cert prefix cert >>= fun vm_config ->
+  Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
+  (* check whether vm with same name is already running *)
+  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 () ->
+  (* 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 res ->
+  (* check static policies *)
+  Logs.debug (fun m -> m "now checking static policies") ;
+  check_policies vm_config (List.map snd res) >>= fun () ->
+  (* check dynamic usage *)
+  Logs.debug (fun m -> m "now checking dynamic policies") ;
+  Vmm_resources.check_dynamic t.resources vm_config res >>= fun resource_usage ->
+  (* prepare VM: save VM image to disk, create fifo, ... *)
+  Vmm_commands.prepare vm_config >>= fun (fifo, vmimage, taps) ->
+  Logs.debug (fun m -> m "prepared vm %a" Fpath.pp vmimage) ;
+  Ok (filename vm_config,
+      fun t s ->
+        (* actually execute the vm *)
+        Vmm_commands.exec t.dir vm_config fifo vmimage taps >>= fun vm ->
+        Logs.debug (fun m -> m "exec()ed vm") ;
+        Vmm_resources.insert t.resources full vm >>= fun resources ->
+        Logs.debug (fun m -> m "%a" Vmm_resources.pp resources) ;
+        let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.pid vm.taps in
+        let bridges =
+          List.fold_left2 (fun b br ta ->
+              let old = match String.Map.find br b with
+                | None -> String.Set.empty
+                | Some x -> x
+              in
+              String.Map.add br (String.Set.add ta old) b)
+            t.bridges vm_config.network taps
+        in
+        let t = { t with resources ; stats_counter = succ t.stats_counter ; bridges } in
+        let t, out = log t (Log.hdr prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in
+        let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in
+        Ok (t, `Tls (s, tls_out) :: stat t stat_out @ out, vm))
+
+let handle_shutdown t vm r =
+  (match Vmm_commands.shutdown vm with
+   | Ok () -> ()
+   | Error (`Msg e) -> Logs.warn (fun m -> m "%s during shutdown" e)) ;
+  let resources =
+    match Vmm_resources.remove t.resources (fullname vm.config) vm with
+    | Ok resources ->
+      Logs.debug (fun m -> m "shut down: %a" Vmm_resources.pp resources) ;
+      resources
+    | Error (`Msg e) ->
+      Logs.warn (fun m -> m "%s while removing vm" e) ;
+      t.resources
+  in
+  let 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.bridges vm.config.network vm.taps
+  in
+  let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.pid in
+  let t = { t with stats_counter = succ t.stats_counter ; resources ; bridges } 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
+          match x with
+          | `Info ->
+            Logs.debug (fun m -> m "resources are %a" Vmm_resources.pp t.resources) ;
+            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_image ->
+            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 name = String.concat ~sep:"." arg in
+            let on_success t =
+              let cons = Vmm_wire.Console.history t.console_counter t.console_version name Ptime.epoch in
+              let old = match String.Map.find name t.console_attached with
+                | None -> []
+                | Some s ->
+                  let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
+                  [ `Tls (s, out) ]
+              in
+              let console_attached = String.Map.add name s t.console_attached in
+              { t with console_counter = succ t.console_counter ; console_attached },
+              `Raw (t.console_socket, cons) :: old
+            in
+            let cons = Vmm_wire.Console.attach t.console_counter t.console_version name in
+            let console_requests = IM.add t.console_counter on_success t.console_requests in
+            Ok ({ t with console_counter = succ t.console_counter ; console_requests },
+                [ `Raw (t.console_socket, cons) ])
+          | `Detach ->
+            let name = String.concat ~sep:"." arg in
+            let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in
+            (match String.Map.find name t.console_attached with
+             | None -> Error (`Msg "not attached")
+             | Some x when t.cmp x s -> Ok (String.Map.remove name t.console_attached)
+             | Some _ -> 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 vm.Vmm_core.pid in
+                  let stats_requests = IM.add t.stats_counter (s, hdr.Vmm_wire.id) 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
+          | _ -> 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 =
+    match String.Map.find (string_of_id prefix) 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 (string_of_id prefix) 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.to_float_s (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 x, None -> Error (`Msg "CRL number not present")
+     | Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
+  (* filename should be whatever_dir / crls / <id> *)
+  let filename = Fpath.(t.dir / "crls" / string_of_id prefix) in
+  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 x -> 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 t, out = log t (Log.hdr prefix (id leaf), `Login addr) in
+  Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
+  if List.mem `Image perms && Vmm_asn.contains_vm leaf then
+    handle_create t prefix chain leaf >>= fun (file, cont) ->
+    let cons = Vmm_wire.Console.add t.console_counter t.console_version file in
+    Ok ({ t with console_counter = succ t.console_counter },
+        `Raw (t.console_socket, cons) :: out,
+        `Create cont)
+  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 },
+        out,
+        `Loop (prefix, perms))
+
+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) ->
+      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.StatReply ->
+          let out = Client.stat data req_id state.client_version in
+          [ `Tls (s, out) ]
+        | 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.err (fun m -> m "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

@@ -0,0 +1,56 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+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
+| Unix.WSTOPPED s -> Fmt.pf ppf "stopped by signal %a" Fmt.Dump.signal s
+
+let ret = function
+  | Unix.WEXITED c -> `Exit c
+  | Unix.WSIGNALED s -> `Signal s
+  | Unix.WSTOPPED s -> `Stop s
+
+let wait_and_clear pid stdout =
+  let open Lwt.Infix in
+  Lwt_unix.waitpid [] pid >>= fun (_, s) ->
+  Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ;
+  Vmm_commands.close_no_err stdout ;
+  Lwt.return (ret s)
+
+let read_exactly s =
+  let buf = Bytes.create 8 in
+  let rec r b i l =
+    Lwt_unix.read s b i l >>= function
+    | 0 -> Lwt.fail_with "end of file"
+    | n when n == l -> Lwt.return_unit
+    | n when n < l -> r b (i + n) (l - n)
+    | _ -> Lwt.fail_with "read too much"
+  in
+  r buf 0 8 >>= fun () ->
+  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 >|= fun () ->
+      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)
+    else
+      Lwt.return (Ok (hdr, ""))
+
+let write_raw s buf =
+  let buf = Bytes.unsafe_of_string buf in
+  let rec w off l =
+    Lwt_unix.send s buf off l [] >>= fun n ->
+    if n = l then
+      Lwt.return_unit
+    else
+      w (off + n) (l - n)
+  in
+  Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ;
+  w 0 (Bytes.length buf)

src/vmm_resources.ml

@@ -0,0 +1,125 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Astring
+open Rresult.R.Infix
+
+open Vmm_core
+
+type res_entry = {
+  vms : int ;
+  memory : int ;
+}
+
+let pp_res_entry ppf res =
+  Fmt.pf ppf "%d vms %d memory" res.vms res.memory
+
+let empty_res = { vms = 0 ; memory = 0 }
+
+let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) =
+  succ res.vms <= policy.vms && res.memory + vm.memory <= policy.memory
+
+let add (vm : vm) (res : res_entry) =
+  { vms = succ res.vms ; memory = vm.config.memory + res.memory }
+
+let rem (vm : vm) (res : res_entry) =
+  { vms = pred res.vms ; memory = res.memory - vm.config.memory }
+
+type entry =
+  | Leaf of vm
+  | Subtree of res_entry * entry String.Map.t
+
+type t = entry String.Map.t
+
+let empty = String.Map.empty
+
+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 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 pp ppf map =
+  Fmt.pf ppf "%a"
+    Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
+    (String.Map.bindings map)
+
+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 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
+  | _ -> None
+
+let rec iter f = function
+  | Leaf vm -> f vm
+  | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m)
+
+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 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 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)
+        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

src/vmm_resources.mli

@@ -0,0 +1,56 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(** A tree data structure tracking dynamic resource usage.
+
+    Considering delegation of resources to someone, and further delegation
+    to others - using a process which is not controlled by the authority -
+    requires runtime tracking of these delegations and the actual usage:
+
+    If Alice may create 2 virtual machines, and she delegates the same
+    capability further to both Bob and Charlie, the authority must still enforce
+    that Alice, Bob, and Charlie are able to run 2 virtual machines in total,
+    rather than 2 each. *)
+
+(** 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
+
+(** [fold f entry acc] folds [f] over [entry]. *)
+val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a
+
+(** [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
+
+(** [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

src/vmm_ring.ml

@@ -0,0 +1,38 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(* a ring buffer with N strings, dropping old ones *)
+
+type t = {
+  data : (Ptime.t * string) array ;
+  mutable write : int ;
+  size : int ;
+}
+
+let create ?(size = 1024) () =
+  { data = Array.make 1024 (Ptime.min, "") ; write = 0 ; size }
+
+let inc t = (succ t.write) mod t.size
+
+let write t v =
+  Array.set t.data t.write v ;
+  t.write <- inc t
+
+let dec t n = (pred n + t.size) mod t.size
+
+let earlier ts than =
+  if ts = Ptime.min then true
+  else Ptime.is_earlier ts ~than
+
+let read_history t than =
+  let rec go s acc idx =
+    if idx = s then (* don't read it twice *)
+      acc
+    else
+      let ts, v = Array.get t.data idx in
+      if earlier ts than then acc
+      else go s ((ts, v) :: acc) (dec t idx)
+  in
+  let idx = dec t t.write in
+  let ts, v = Array.get t.data idx in
+  if earlier ts than then []
+  else go idx [(ts,v)] (dec t idx)

src/vmm_tls.ml

@@ -0,0 +1,35 @@
+(* (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_unit
+    else
+      Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
+      | 0 -> Lwt.fail_with "read 0 bytes"
+      | x when x == l -> Lwt.return_unit
+      | x when x < l -> r_n buf (off + x) tot
+      | _ -> Lwt.fail_with "overread, will never happen"
+  in
+  let buf = Cstruct.create 8 in
+  r_n buf 0 8 >>= fun () ->
+  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 >|= fun () ->
+      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, ""))
+
+let write_tls s buf =
+  Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ;
+  Tls_lwt.Unix.write s (Cstruct.of_string buf)

src/vmm_wire.ml

@@ -0,0 +1,662 @@
+(* (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 ]
+
+let version_to_int = function
+  | `WV0 -> 0
+
+let version_of_int = function
+  | 0 -> Ok `WV0
+  | _ -> Error (`Msg "unknown wire version")
+
+let version_eq a b = match a, b with
+  | `WV0, `WV0 -> true
+
+let pp_version ppf v =
+  Fmt.string ppf (match v with
+      | `WV0 -> "wire version 0")
+
+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
+      | Attach
+      | Detach
+      | 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 name
+
+  let attach id v name = encode id v Attach name
+
+  let detach id v name = encode id v Detach 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
+      | Statistics
+      | StatReply
+    [@@uint16_t]
+  ]
+
+  let encode id version op ?payload pid =
+    let pid = encode_pid pid in
+    let length, p =
+      match payload with
+      | None -> 4, empty
+      | Some x -> 4 + Cstruct.len x, x
+    and tag = op_to_int op
+    in
+    let r =
+      Cstruct.concat [ create_header { length ; version ; id ; tag } ; pid ; 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_exact 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 pid taps =
+    let payload = encode_strings taps in
+    encode id v Add ~payload pid
+
+  let remove id v pid = encode id v Remove pid
+
+  let stat id v pid = encode id v Statistics pid
+
+  let stat_reply id version payload =
+    let length = Cstruct.len payload
+    and tag = op_to_int StatReply
+    in
+    let r =
+      Cstruct.append (create_header { length ; id ; version ; tag }) payload
+    in
+    Cstruct.to_string r
+
+  let encode_stats (ru, ifd) =
+    Cstruct.concat
+      (encode_rusage ru :: List.map encode_ifdata ifd)
+
+  let decode_stats cs =
+    check_len cs 144 >>= fun () ->
+    let ru, ifd = Cstruct.split cs 144 in
+    decode_rusage ru >>= fun ru ->
+    let rec go acc buf =
+      if Cstruct.len buf = 0 then
+        Ok (List.rev acc)
+      else
+        decode_ifdata buf >>= fun (this, used) ->
+        go (this :: acc) (Cstruct.shift buf used)
+    in
+    go [] ifd >>= fun ifs ->
+    Ok (ru, 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_image -> 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_image
+    | 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

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

stats/vmm_stats.ml

@@ -0,0 +1,126 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+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"
+
+let my_version = `WV0
+
+type t = {
+  pid_nic : (int * string) list IM.t ;
+  pid_rusage : rusage IM.t ;
+  old_pid_rusage : rusage IM.t ;
+  nic_ifdata : ifdata String.Map.t ;
+  old_nic_ifdata : ifdata String.Map.t ;
+}
+
+let empty () =
+  { pid_nic = IM.empty ;
+    pid_rusage = IM.empty ; nic_ifdata = String.Map.empty ;
+    old_pid_rusage = IM.empty ; old_nic_ifdata = String.Map.empty }
+
+let rec safe_sysctl f arg =
+  try Some (f arg) with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> safe_sysctl f arg
+  | _ -> None
+
+let gather pid nics =
+  safe_sysctl sysctl_rusage pid,
+  List.fold_left (fun ifd (nic, _) ->
+      match safe_sysctl sysctl_ifdata nic with
+      | None -> ifd
+      | Some data -> String.Map.add data.name data ifd)
+    String.Map.empty nics
+
+let tick t =
+  let pid_rusage, nic_ifdata =
+    IM.fold (fun pid nics (rus, ifds) ->
+        let ru, ifd = gather pid nics in
+        (match ru with
+         | None -> rus
+         | Some ru -> IM.add pid ru rus),
+        String.Map.union (fun _k a _b -> Some a) ifd ifds)
+      t.pid_nic (IM.empty, String.Map.empty)
+  in
+  let old_pid_rusage, old_nic_ifdata = t.pid_rusage, t.nic_ifdata in
+  { t with pid_rusage ; nic_ifdata ; old_pid_rusage ; old_nic_ifdata }
+
+let add_pid t pid nics =
+  match safe_sysctl sysctl_ifcount () with
+  | None -> Error (`Msg "sysctl ifcount failed")
+  | Some max_nic ->
+    let rec go cnt acc id =
+      if id > 0 && cnt > 0 then
+        match safe_sysctl 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
+    let nic_ids = go (List.length nics) [] max_nic in
+    let pid_nic = IM.add pid nic_ids t.pid_nic in
+    let ru, ifd = gather pid nic_ids in
+    (match ru with
+     | None -> ()
+     | Some ru -> Logs.info (fun m -> m "RU %a" pp_rusage ru)) ;
+    Logs.info (fun m -> m "interfaces: %a" Fmt.(list ~sep:(unit ",@ ") pp_ifdata) (snd (List.split (String.Map.bindings ifd)))) ;
+    Ok { t with pid_nic }
+
+(* TODO: we can now compute deltas: t contains also old ru & ifdata *)
+let stats t pid =
+  try
+    let nics = IM.find pid t.pid_nic in
+    let ru = IM.find pid t.pid_rusage 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, ifd)
+  with
+  | _ -> Error (`Msg "failed to find resource usage")
+
+let remove_pid t pid =
+  (* can this err? -- do I care? *)
+  let pid_nic = IM.remove pid t.pid_nic in
+  { t with pid_nic }
+
+open Rresult.R.Infix
+
+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
+      match int_to_op hdr.tag with
+      | Some Add ->
+        decode_pid_taps cs >>= fun (pid, taps) ->
+        add_pid t pid taps >>= fun t ->
+        Ok (t, success ~msg:"added" hdr.id my_version)
+      | Some Remove ->
+        decode_pid cs >>= fun pid ->
+        let t = remove_pid t pid in
+        Ok (t, success ~msg:"removed" hdr.id my_version)
+      | Some Statistics ->
+        decode_pid cs >>= fun pid ->
+        stats t pid >>= fun s ->
+        Ok (t, stat_reply hdr.id my_version (encode_stats s))
+      | _ -> Error (`Msg "unknown command")
+  in
+  match r with
+  | Ok (t, out) -> t, out
+  | Error (`Msg msg) ->
+    Logs.err (fun m -> m "error while processing %s" msg) ;
+    t, fail ~msg hdr.id my_version

stats/vmm_stats_lwt.ml

@@ -0,0 +1,78 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+(* the process responsible for gathering statistics (CPU + mem + network) *)
+
+(* a shared unix domain socket between vmmd and vmm_stats is used as
+   communication channel, where the vmmd can issue commands:
+
+   - add pid taps
+   - remove pid
+   - statistics pid
+
+   every 5 minutes, statistics of all registered pids are recorded. `statistics`
+   reports last recorded stats *)
+
+open Lwt.Infix
+
+let t = ref (Vmm_stats.empty ())
+
+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 s addr () =
+  Logs.info (fun m -> m "handling stats 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 ()
+    | Ok (hdr, data) ->
+      Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ;
+      let t', out = Vmm_stats.handle !t hdr data in
+      t := t' ;
+      Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
+      Vmm_lwt.write_raw s out >>= fun () ->
+      loop ()
+  in
+  loop ()
+
+let rec timer () =
+  t := Vmm_stats.tick !t ;
+  Lwt_unix.sleep Duration.(to_f (of_min 5)) >>= fun () ->
+  timer ()
+
+let jump _ file =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+     Lwt_unix.(Versioned.bind_2 s (ADDR_UNIX file)) >>= fun () ->
+     Lwt_unix.listen s 1 ;
+     Lwt.async timer ;
+     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 onto" in
+  Arg.(value & pos 0 string "" & info [] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ socket)),
+  Term.info "vmm_stats" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

stats/vmm_stats_stubs.c

@@ -0,0 +1,152 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/unixsupport.h>
+
+#include <sys/param.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+#include <sys/user.h>
+#include <sys/sysctl.h>
+#include <net/if.h>
+
+#ifdef __FreeBSD__
+#include <net/if_mib.h>
+#endif
+
+#define Val32 caml_copy_int32
+#define Val64 caml_copy_int64
+
+#ifdef __FreeBSD__
+CAMLprim value vmmanage_sysctl_rusage (value pid_r) {
+  CAMLparam1(pid_r);
+  CAMLlocal3(res, utime, stime);
+  int name[4];
+  int error;
+  size_t len;
+  struct kinfo_proc p;
+  struct rusage ru;
+
+  len = sizeof(p);
+  name[0] = CTL_KERN;
+  name[1] = KERN_PROC;
+  name[2] = KERN_PROC_PID;
+  name[3] = Int_val(pid_r);
+
+  error = sysctl(name, nitems(name), &p, &len, NULL, 0);
+  if (error < 0)
+    uerror("sysctl", Nothing);
+
+  if (ru.ru_utime.tv_usec < 0 || ru.ru_utime.tv_usec > 999999999 ||
+      ru.ru_stime.tv_usec < 0 || ru.ru_stime.tv_usec > 999999999)
+    uerror("sysctl", Nothing);
+
+  ru = p.ki_rusage;
+  utime = caml_alloc(2, 0);
+  Store_field (utime, 0, Val64(ru.ru_utime.tv_sec));
+  Store_field (utime, 1, Val_int(ru.ru_utime.tv_usec));
+  stime = caml_alloc(2, 0);
+  Store_field (stime, 0, Val64(ru.ru_stime.tv_sec));
+  Store_field (stime, 1, Val_int(ru.ru_stime.tv_usec));
+  res = caml_alloc(16, 0);
+  Store_field (res, 0, utime);
+  Store_field (res, 1, stime);
+  Store_field (res, 2, Val64(ru.ru_maxrss));
+  Store_field (res, 3, Val64(ru.ru_ixrss));
+  Store_field (res, 4, Val64(ru.ru_idrss));
+  Store_field (res, 5, Val64(ru.ru_isrss));
+  Store_field (res, 6, Val64(ru.ru_minflt));
+  Store_field (res, 7, Val64(ru.ru_majflt));
+  Store_field (res, 8, Val64(ru.ru_nswap));
+  Store_field (res, 9, Val64(ru.ru_inblock));
+  Store_field (res, 10, Val64(ru.ru_oublock));
+  Store_field (res, 11, Val64(ru.ru_msgsnd));
+  Store_field (res, 12, Val64(ru.ru_msgrcv));
+  Store_field (res, 13, Val64(ru.ru_nsignals));
+  Store_field (res, 14, Val64(ru.ru_nvcsw));
+  Store_field (res, 15, Val64(ru.ru_nivcsw));
+
+  CAMLreturn(res);
+}
+
+CAMLprim value vmmanage_sysctl_ifcount (value unit) {
+  CAMLparam1(unit);
+  int data = 0;
+  size_t dlen = 0;
+  int name[5];
+
+  name[0] = CTL_NET;
+  name[1] = PF_LINK;
+  name[2] = NETLINK_GENERIC;
+  name[3] = IFMIB_SYSTEM;
+  name[4] = IFMIB_IFCOUNT;
+  dlen = sizeof(data);
+
+  if (sysctl(name, nitems(name), &data, &dlen, NULL, 0) != 0)
+    uerror("sysctl", Nothing);
+
+  CAMLreturn(Val_long(data));
+}
+
+CAMLprim value vmmanage_sysctl_ifdata (value num) {
+  CAMLparam1(num);
+  CAMLlocal1(res);
+  size_t datalen;
+  int name[6];
+  struct ifmibdata data;
+
+  name[0] = CTL_NET;
+  name[1] = PF_LINK;
+  name[2] = NETLINK_GENERIC;
+  name[3] = IFMIB_IFDATA;
+  name[4] = Int_val(num);
+  name[5] = IFDATA_GENERAL;
+  datalen = sizeof(data);
+
+  if (sysctl(name, nitems(name), &data, &datalen, NULL, 0) != 0)
+    uerror("sysctl", Nothing);
+
+  res = caml_alloc(18, 0);
+  Store_field(res, 0, caml_copy_string(data.ifmd_name));
+  Store_field(res, 1, Val32(data.ifmd_flags));
+  Store_field(res, 2, Val32(data.ifmd_snd_len));
+  Store_field(res, 3, Val32(data.ifmd_snd_maxlen));
+  Store_field(res, 4, Val32(data.ifmd_snd_drops));
+  Store_field(res, 5, Val32(data.ifmd_data.ifi_mtu));
+  Store_field(res, 6, Val64(data.ifmd_data.ifi_baudrate));
+  Store_field(res, 7, Val64(data.ifmd_data.ifi_ipackets));
+  Store_field(res, 8, Val64(data.ifmd_data.ifi_ierrors));
+  Store_field(res, 9, Val64(data.ifmd_data.ifi_opackets));
+  Store_field(res, 10, Val64(data.ifmd_data.ifi_oerrors));
+  Store_field(res, 11, Val64(data.ifmd_data.ifi_collisions));
+  Store_field(res, 12, Val64(data.ifmd_data.ifi_ibytes));
+  Store_field(res, 13, Val64(data.ifmd_data.ifi_obytes));
+  Store_field(res, 14, Val64(data.ifmd_data.ifi_imcasts));
+  Store_field(res, 15, Val64(data.ifmd_data.ifi_omcasts));
+  Store_field(res, 16, Val64(data.ifmd_data.ifi_iqdrops));
+  Store_field(res, 17, Val64(data.ifmd_data.ifi_oqdrops));
+
+  CAMLreturn(res);
+}
+#else /* FreeBSD */
+
+/* stub symbols for OS currently not supported */
+
+CAMLprim value vmmanage_sysctl_rusage (value pid_r) {
+  CAMLparam1(pid_r);
+  uerror("sysctl", Nothing);
+}
+
+CAMLprim value vmmanage_sysctl_ifcount (value unit) {
+  CAMLparam1(unit);
+  uerror("sysctl", Nothing);
+}
+
+CAMLprim value vmmanage_sysctl_ifdata (value num) {
+  CAMLparam1(num);
+  uerror("sysctl", Nothing);
+}
+
+#endif