albatross_daemon: discover root policy and insert this

Previously, there was no such thing. Now, to be able to avoid overcommitment, we
discover the available cpus, memory, block device size, and bridges at startup.
This results in some changed semantics:
- if a bridge used by some policy is not configured, we bail early
- if the policies lead to overcommitment, we bail early

We discover the root policy at startup each time (and also compare to the
previous one), since we want to discover the data of the current system. It may
be different from the previous one (network bridges, available memory, ...).

daemon/albatrossd.ml

@@ -168,9 +168,21 @@ let jump _ systemd influx tmpdir dbdir =
   (match Vmm_unix.check_commands () with
    | Error `Msg m -> invalid_arg m
    | Ok () -> ());
+  let root_policy =
+    match Vmm_unix.root_policy () with
+    | Error `Msg m -> invalid_arg m
+    | Ok p ->
+      Logs.app (fun m -> m "root policy: %a" Policy.pp p);
+      p
+  in
   match Vmm_vmmd.restore_state () with
   | Error (`Msg msg) -> Logs.err (fun m -> m "bailing out: %s" msg)
   | Ok (old_unikernels, policies) ->
+    let policies, old_p = Vmm_trie.insert Name.root root_policy policies in
+    Option.iter (fun p ->
+        if not (Policy.equal p root_policy) then
+          Logs.warn (fun m -> m "replacing stored root policy %a with discovered %a"
+                        Policy.pp p Policy.pp root_policy)) old_p;
     match Vmm_vmmd.restore_policies !state policies with
     | Error `Msg msg ->
       Logs.err (fun m -> m "policy restore error: %s" msg)

src/dune

@@ -14,4 +14,8 @@
  (wrapped false)
  (modules vmm_unix vmm_lwt vmm_vmmd)
  (libraries albatross ipaddr.unix bos solo5-elftool lwt lwt.unix ptime.clock.os
-   digestif))
+   digestif)
+ (foreign_stubs
+  (language c)
+  (names vmm_stubs)
+  (flags (:standard))))

src/vmm_stubs.c

@@ -0,0 +1,36 @@
+// (c) 2017, 2018 Hannes Mehnert, all rights reserved
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/unixsupport.h>
+
+#include <unistd.h>
+
+CAMLprim value vmm_cpu_count (value unit) {
+  CAMLparam1(unit);
+  int r;
+  r = (int)sysconf(_SC_NPROCESSORS_CONF);
+  CAMLreturn(Val_int(r));
+}
+
+CAMLprim value vmm_memory (value unit) {
+  CAMLparam1(unit);
+  long pages = sysconf(_SC_PHYS_PAGES);
+  long page_size = sysconf(_SC_PAGE_SIZE);
+  CAMLreturn(Val_int(pages * (page_size / 1024) / 1024));
+}
+
+#include <sys/param.h>
+#include <sys/mount.h>
+
+CAMLprim value vmm_disk_space (value path) {
+  CAMLparam1(path);
+  struct statfs s;
+  const char *p = String_val(path);
+  if (statfs(p, &s) < 0)
+    uerror("statfs", Nothing);
+  CAMLreturn(Val_int(s.f_blocks * s.f_bsize / 1024 / 1024));
+}
+

src/vmm_unix.ml

@@ -488,3 +488,42 @@ let find_block_devices () =
         | Ok size, Ok id ->
           Ok ((id, size) :: acc))
     (Ok []) files
+
+external cpu_count : unit -> int = "vmm_cpu_count"
+
+external disk_space : string -> int = "vmm_disk_space"
+
+external memory : unit -> int = "vmm_memory"
+
+let find_bridges () =
+  match Lazy.force uname with
+  | FreeBSD ->
+    let cmd = Bos.Cmd.(v "ifconfig" % "-g" % "bridge") in
+    let* names = Bos.OS.Cmd.(run_out cmd |> out_lines |> success) in
+    Ok names
+  | Linux ->
+    let* bridges = Bos.(OS.Cmd.(run_out Cmd.(v "ip" % "-o" % "link" % "show" % "type" % "bridge") |> out_lines |> success)) in
+    (* output is <id>: <name>: ... *)
+    Ok (List.fold_left (fun acc s ->
+        match String.split_on_char ':' s with
+        | _id :: name :: _tl -> String.trim name :: acc
+        | _ -> Logs.err (fun m -> m "couldn't find bridge name in %s" s); acc)
+        [] bridges)
+
+let root_policy () =
+  try
+    let cpus = cpu_count () in
+    let disk_space = disk_space (Fpath.to_string (block_dir ())) in
+    let memory = memory () in
+    let* bridges = find_bridges () in
+    let rec gen_cpu acc n =
+      if n = 0 then acc else gen_cpu (Vmm_core.IS.add (pred n) acc) (pred n)
+    in
+    Ok { Vmm_core.Policy.vms = max_int ;
+         cpuids = gen_cpu Vmm_core.IS.empty cpus ;
+         memory ;
+         block = Some disk_space ;
+         bridges = String_set.of_list bridges }
+  with
+  | Unix.Unix_error (e, _, _) ->
+    Error (`Msg (Fmt.str "root policy failed: %a" pp_unix_err e))

src/vmm_unix.mli

@@ -43,3 +43,5 @@ val vm_device : Unikernel.t -> (string, [> `Msg of string ]) result
 val manifest_devices_match : bridges:(string * string option * Macaddr.t option) list ->
   block_devices:(string * string option * int option) list -> string ->
   (unit, [> `Msg of string]) result
+
+val root_policy : unit -> (Policy.t, [> `Msg of string ]) result