Store the policies next to the unikernels on disk

The purpose is, while developing mollymawk - we discovered that the policies
are ephemeral - thus if you have some unikernels dumped on disk, and (re)start
albatross, they will be created (great!), but a policy_info command will return
nothing. The issue is that in mollymawk we don't want to duplicate the storage
effort, but rely on having the policy(ies) available - to generate intermediate
certificates that are nice.

To describe it a bit more technical:
 albatross is running a bunch of unikernels, deployed via TLS
 albatross is stopped
 albatross is started, unikernels are restarted
 mollymawk is started and retrieves the policies from albatross
   <- here, we read before this commit the empty set
 mollymawk tries to do something, and needs to create an intermediate
  certificate -- and by default pushes a VM=0, mem=0 policy
  <- here, all goes to hell. this is what we like to avoid

Still, mollymawk is a bit special, since it reads the policies only on startup.
This means an albatross with command-line policy modifications won't be updated
in mollymawk. I guess the path forward is to notice that and make mollymawk the
source of truth for policies (i.e. allow people to extract certificates for
command line usage, provide the CA facility).

client/albatross_client.ml

@@ -814,17 +814,23 @@ let inspect_dump _ name dbdir =
   | Error (`Msg msg) ->
     Logs.err (fun m -> m "error while reading dump file: %s" msg);
     Cli_failed
-  | Ok data -> match Vmm_asn.unikernels_of_str data with
+  | Ok data -> match Vmm_asn.state_of_str data with
     | Error (`Msg msg) ->
       Logs.err (fun m -> m "couldn't parse dump file: %s" msg);
       Cli_failed
-    | Ok unikernels ->
-      let all = Vmm_trie.all unikernels in
-      Logs.app (fun m -> m "parsed %d unikernels:" (List.length all));
+    | Ok (unikernels, policies) ->
+      let uniks = Vmm_trie.all unikernels in
+      Logs.app (fun m -> m "parsed %u unikernels:" (List.length uniks));
       List.iter (fun (name, unik) ->
           Logs.app (fun m -> m "%a: %a" Vmm_core.Name.pp name
                        Vmm_core.Unikernel.pp_config unik))
-        all;
+        uniks;
+      let ps = Vmm_trie.all policies in
+      Logs.app (fun m -> m "parsed %u policies:" (List.length ps));
+      List.iter (fun (name, p) ->
+          Logs.app (fun m -> m "%a: %a" Vmm_core.Name.pp name
+                       Vmm_core.Policy.pp p))
+        ps;
       Success
 
 let cert () dst server_ca cert key =

daemon/albatrossd.ml

@@ -168,71 +168,76 @@ let jump _ systemd influx tmpdir dbdir =
   (match Vmm_unix.check_commands () with
    | Error `Msg m -> invalid_arg m
    | Ok () -> ());
-  match Vmm_vmmd.restore_unikernels () with
+  match Vmm_vmmd.restore_state () with
   | Error (`Msg msg) -> Logs.err (fun m -> m "bailing out: %s" msg)
-  | Ok old_unikernels ->
-    Lwt_main.run
-      (let console_path = socket_path `Console in
-       (Vmm_lwt.connect Lwt_unix.PF_UNIX (Lwt_unix.ADDR_UNIX console_path) >|= function
-         | Some x -> x
-         | None ->
-           failwith ("Failed to connect to " ^ console_path ^ ", is albatross-console started?")) >>= fun c ->
-       Albatrossd_utils.init_influx "albatross" influx;
-       let listen_socket () =
-         if systemd then Vmm_lwt.systemd_socket ()
-         else Vmm_lwt.service_socket `Vmmd
-       in
-       Lwt.catch listen_socket
-         (fun e ->
-            let str =
-              Fmt.str "unable to create server socket %a: %s"
-                pp_socket `Vmmd (Printexc.to_string e)
-            in
-            invalid_arg str) >>= fun ss ->
-       let self_destruct_mutex = Lwt_mutex.create () in
-       let self_destruct () =
-         Lwt_mutex.with_lock self_destruct_mutex (fun () ->
+  | Ok (old_unikernels, policies) ->
+    match Vmm_vmmd.restore_policies !state policies with
+    | Error `Msg msg ->
+      Logs.err (fun m -> m "policy restore error: %s" msg)
+    | Ok state' ->
+      state := state';
+      Lwt_main.run
+        (let console_path = socket_path `Console in
+         (Vmm_lwt.connect Lwt_unix.PF_UNIX (Lwt_unix.ADDR_UNIX console_path) >|= function
+           | Some x -> x
+           | None ->
+             failwith ("Failed to connect to " ^ console_path ^ ", is albatross-console started?")) >>= fun c ->
+         Albatrossd_utils.init_influx "albatross" influx;
+         let listen_socket () =
+           if systemd then Vmm_lwt.systemd_socket ()
+           else Vmm_lwt.service_socket `Vmmd
+         in
+         Lwt.catch listen_socket
+           (fun e ->
+              let str =
+                Fmt.str "unable to create server socket %a: %s"
+                  pp_socket `Vmmd (Printexc.to_string e)
+              in
+              invalid_arg str) >>= fun ss ->
+         let self_destruct_mutex = Lwt_mutex.create () in
+         let self_destruct () =
+           Lwt_mutex.with_lock self_destruct_mutex (fun () ->
+               Lwt_mutex.with_lock create_lock (fun () ->
+                   Vmm_lwt.safe_close ss >>= fun () ->
+                   let state', tasks = Vmm_vmmd.killall !state Lwt.task in
+                   state := state';
+                   Lwt.return tasks) >>= fun tasks ->
+               Lwt.join (List.map (Lwt.map ignore) tasks))
+         in
+         Sys.(set_signal sigterm
+                (Signal_handle (fun _ -> Lwt.async self_destruct)));
+         let cons_out = write_reply "cons" c
+         and stat_out txt wire = match !stats_fd with
+           | None ->
+             Logs.info (fun m -> m "ignoring stat %s %a" txt
+                           (Vmm_commands.pp_wire ~verbose:false) wire);
+             Lwt.return_unit
+           | Some s ->
+             write_reply "stat" s txt wire >|= function
+             | Ok () -> ()
+             | Error `Msg msg ->
+               Logs.err (fun m -> m "error while writing to stats: %s" msg);
+               stats_fd := None
+         in
+         Lwt_list.iter_s (fun (name, config) ->
              Lwt_mutex.with_lock create_lock (fun () ->
-                 Vmm_lwt.safe_close ss >>= fun () ->
-                 let state', tasks = Vmm_vmmd.killall !state Lwt.task in
-                 state := state';
-                 Lwt.return tasks) >>= fun tasks ->
-             Lwt.join (List.map (Lwt.map ignore) tasks))
-       in
-       Sys.(set_signal sigterm
-              (Signal_handle (fun _ -> Lwt.async self_destruct)));
-       let cons_out = write_reply "cons" c
-       and stat_out txt wire = match !stats_fd with
-         | None ->
-           Logs.info (fun m -> m "ignoring stat %s %a" txt
-                         (Vmm_commands.pp_wire ~verbose:false) wire);
-           Lwt.return_unit
-         | Some s ->
-           write_reply "stat" s txt wire >|= function
-           | Ok () -> ()
-           | Error `Msg msg ->
-             Logs.err (fun m -> m "error while writing to stats: %s" msg);
-             stats_fd := None
-       in
-       Lwt_list.iter_s (fun (name, config) ->
-           Lwt_mutex.with_lock create_lock (fun () ->
-               create stat_out cons_out stub_data_out name config))
-         (Vmm_trie.all old_unikernels) >>= fun () ->
-       Lwt.catch (fun () ->
-           let rec loop () =
-             Lwt_unix.accept ss >>= fun (fd, addr) ->
-             Lwt_unix.set_close_on_exec fd ;
-             m `Open;
-             Lwt.async (fun () ->
-                 handle cons_out stat_out fd addr >|= fun () ->
-                 m `Close) ;
-             loop ()
-           in
-           loop ())
-         (fun e ->
-            Logs.err (fun m -> m "exception %s, shutting down"
-                         (Printexc.to_string e));
-            self_destruct ()))
+                 create stat_out cons_out stub_data_out name config))
+           (Vmm_trie.all old_unikernels) >>= fun () ->
+         Lwt.catch (fun () ->
+             let rec loop () =
+               Lwt_unix.accept ss >>= fun (fd, addr) ->
+               Lwt_unix.set_close_on_exec fd ;
+               m `Open;
+               Lwt.async (fun () ->
+                   handle cons_out stat_out fd addr >|= fun () ->
+                   m `Close) ;
+               loop ()
+             in
+             loop ())
+           (fun e ->
+              Logs.err (fun m -> m "exception %s, shutting down"
+                           (Printexc.to_string e));
+              self_destruct ()))
 
 open Cmdliner
 

src/vmm_asn.ml

@@ -15,8 +15,8 @@
    --use-version command-line flag - so new clients can talk to old servers).
 
    It should be ensured that old unikernels dumped to disk (a) can be read by
-   new albatross daemons. The functions unikernels_to_str and
-   unikernels_of_str are used for dump and restore, each an explicit choice.
+   new albatross daemons. The functions state_to_str and
+   state_of_str are used for dump and restore, each an explicit choice.
    They use the trie of unikernel_config, dump always uses the latest version in
    the explicit choice. There's no version field involved.
 
@@ -832,26 +832,35 @@ let version2_unikernels = trie v2_unikernel_config
 
 let version3_unikernels = trie unikernel_config
 
-let unikernels =
+let policies = trie policy
+
+let state =
   (* the choice is the implicit version + migration... be aware when
      any dependent data layout changes .oO(/o\) *)
   let f = function
-    | `C1 data -> data
-    | `C2 data -> data
-    | `C3 data -> data
-    | `C4 data -> data
-  and g data =
-    `C4 data
+    | `C1 data -> data, Vmm_trie.empty
+    | `C2 data -> data, Vmm_trie.empty
+    | `C3 data -> data, Vmm_trie.empty
+    | `C4 data -> data, Vmm_trie.empty
+    | `C5 (data, policies) -> (data, policies)
+  and g (unikernels, policies) =
+    `C5 (unikernels, policies)
   in
   Asn.S.map f g @@
-  Asn.S.(choice4
+  Asn.S.(choice5
            (my_explicit 0 ~label:"unikernel-OLD1" version1_unikernels)
            (my_explicit 1 ~label:"unikernel-OLD0" version0_unikernels)
            (my_explicit 2 ~label:"unikernel-OLD2" version2_unikernels)
-           (my_explicit 3 ~label:"unikernel" version3_unikernels))
+           (my_explicit 3 ~label:"unikernel" version3_unikernels)
+           (my_explicit 4 ~label:"unikernel and policy"
+              (sequence2
+                 (required ~label:"unikernels" version3_unikernels)
+                 (required ~label:"policies" policies)))
+        )
 
-let unikernels_of_str, unikernels_to_str =
-  projections_of unikernels
+let state_of_str, state_to_str =
+  let d, e = projections_of state in
+  d, fun unik ps -> e (unik, ps)
 
 let cert_extension =
   (* note that subCAs are deployed out there, thus modifying the encoding of

src/vmm_asn.mli

@@ -17,5 +17,5 @@ val of_cert_extension :
   string -> (Vmm_commands.version * Vmm_commands.t, [> `Msg of string ]) result
 val to_cert_extension : Vmm_commands.t -> string
 
-val unikernels_to_str : Unikernel.config Vmm_trie.t -> string
-val unikernels_of_str : string -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result
+val state_to_str : Unikernel.config Vmm_trie.t -> Policy.t Vmm_trie.t -> string
+val state_of_str : string -> (Unikernel.config Vmm_trie.t * Policy.t Vmm_trie.t, [> `Msg of string ]) result

src/vmm_vmmd.ml

@@ -38,21 +38,21 @@ let remove_resources t name =
   in
   { t with resources }
 
-let dump_unikernels t =
+let dump_state t =
   let unikernels = Vmm_trie.all t.resources.Vmm_resources.unikernels in
   let trie = List.fold_left (fun t (name, unik) ->
       fst @@ Vmm_trie.insert name unik.Unikernel.config t)
       Vmm_trie.empty unikernels
   in
-  let data = Vmm_asn.unikernels_to_str trie in
+  let data = Vmm_asn.state_to_str trie t.resources.policies in
   match Vmm_unix.dump data with
   | Error (`Msg msg) -> Logs.err (fun m -> m "failed to dump unikernels: %s" msg)
   | Ok () -> Logs.info (fun m -> m "dumped current state")
 
 let waiter t id =
   let t = remove_resources t id in
   let name = Name.to_string id in
-  if not !in_shutdown then dump_unikernels t ;
+  if not !in_shutdown then dump_state t ;
   match String_map.find_opt name t.waiters with
   | None -> t, None
   | Some waiter ->
@@ -134,18 +134,41 @@ type 'a create =
   ('a t -> ('a t * Vmm_commands.wire * Vmm_commands.res * Name.t * Unikernel.t, [ `Msg of string ]) result) *
   (unit -> Vmm_commands.res)
 
-let restore_unikernels () =
+let restore_state () =
   match Vmm_unix.restore () with
   | Error `NoFile ->
     Logs.warn (fun m -> m "no state dump found, starting with no unikernels") ;
-    Ok Vmm_trie.empty
+    Ok (Vmm_trie.empty, Vmm_trie.empty)
   | Error (`Msg msg) -> Error (`Msg ("while reading state: " ^ msg))
   | Ok data ->
-    match Vmm_asn.unikernels_of_str data with
+    match Vmm_asn.state_of_str data with
     | Error (`Msg msg) -> Error (`Msg ("couldn't parse state: " ^ msg))
-    | Ok unikernels ->
-      Logs.info (fun m -> m "restored %d unikernels" (List.length (Vmm_trie.all unikernels))) ;
-      Ok unikernels
+    | Ok (unikernels, policies) ->
+      Logs.info (fun m -> m "restored %u unikernels and %u policies"
+                    (List.length (Vmm_trie.all unikernels))
+                    (List.length (Vmm_trie.all policies))) ;
+      Ok (unikernels, policies)
+
+let restore_policies t policies =
+  let resources =
+    List.fold_left (fun r (name, p) ->
+        match r with
+        | Error _ as e -> e
+        | Ok r ->
+          let path = Name.path name in
+          match Vmm_resources.insert_policy r path p with
+          | Error `Msg msg ->
+            let fmt = Fmt.str "couldn't insert policy %a for %a: %s"
+                Policy.pp p Name.pp name msg
+            in
+            Error (`Msg fmt)
+          | Ok r -> Ok r)
+      (Ok t.resources)
+      (Vmm_trie.all policies)
+  in
+  match resources with
+  | Ok resources -> Ok { t with resources }
+  | Error _ as e -> e
 
 let setup_stats t name vm =
   let stat_out =
@@ -201,7 +224,7 @@ let handle_create t name vm_config =
     Logs.debug (fun m -> m "exec()ed vm") ;
     let resources = Vmm_resources.insert_vm t.resources name vm in
     let t = { t with resources } in
-    dump_unikernels t ;
+    dump_state t ;
     Logs.info (fun m -> m "created %a: %a" Name.pp name Unikernel.pp vm);
     let t, stat_out = setup_stats t name vm in
     Ok (t, stat_out, `Success (`String "created VM"), name, vm)

src/vmm_vmmd.mli

@@ -39,6 +39,8 @@ val handle_command : 'a t -> Vmm_commands.wire ->
 
 val killall : 'a t -> (unit -> 'b * 'a) -> 'a t * 'b list
 
-val restore_unikernels : unit -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result
+val restore_state : unit -> (Unikernel.config Vmm_trie.t * Policy.t Vmm_trie.t, [> `Msg of string ]) result
 
-val dump_unikernels : 'a t -> unit
+val dump_state : 'a t -> unit
+
+val restore_policies : 'a t -> Policy.t Vmm_trie.t -> ('a t, [> `Msg of string ]) result

test/albatross_client_gen.ml

@@ -29,7 +29,7 @@ let unikernels =
   ins "bar:my.nice.unikernel" u2 t
 
 let jump () =
-  let data = Vmm_asn.unikernels_to_str unikernels in
+  let data = Vmm_asn.state_to_str unikernels Vmm_trie.empty in
   print_endline (Base64.encode_string data);
   Ok ()
 

test/tests.ml

@@ -840,7 +840,7 @@ let test_unikernels =
 
 let dec_b64_unik data =
   let data = Base64.decode_exn data in
-  Result.get_ok (Vmm_asn.unikernels_of_str data)
+  fst (Result.get_ok (Vmm_asn.state_of_str data))
 
 let u1_3 =
   Unikernel.{