From e021cccdeb93d131cbdbe263ba6aa2ce6275656e Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 18 Sep 2024 10:21:41 +0200
Subject: [PATCH] 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 | 12 ++++++++++++
 src/dune             |  6 +++++-
 src/vmm_stubs.c      | 36 ++++++++++++++++++++++++++++++++++++
 src/vmm_unix.ml      | 39 +++++++++++++++++++++++++++++++++++++++
 src/vmm_unix.mli     |  2 ++
 5 files changed, 94 insertions(+), 1 deletion(-)
 create mode 100644 src/vmm_stubs.c

diff --git a/daemon/albatrossd.ml b/daemon/albatrossd.ml
index 4c51397..5390042 100644
--- a/daemon/albatrossd.ml
+++ b/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)
diff --git a/src/dune b/src/dune
index 92252fe..c83f0c5 100644
--- a/src/dune
+++ b/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))))
diff --git a/src/vmm_stubs.c b/src/vmm_stubs.c
new file mode 100644
index 0000000..0232138
--- /dev/null
+++ b/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));
+}
+
diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 6c9d42a..3b15cfa 100644
--- a/src/vmm_unix.ml
+++ b/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))
diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli
index b3cb595..aaa617a 100644
--- a/src/vmm_unix.mli
+++ b/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