further rng cleanups (remove deps from dune); albatross-client-inspect-dump which reads a state file (for cautious upgrades)

client/albatross_client_inspect_dump.ml

@@ -0,0 +1,30 @@
+(* (c) 2020 Hannes Mehnert, all rights reserved *)
+
+let jump _ name dbdir =
+  Albatross_cli.set_dbdir dbdir;
+  match Vmm_unix.restore ?name () with
+  | Error `NoFile -> Error (`Msg "dump file not found")
+  | Error (`Msg msg) -> Error (`Msg ("while reading dump file: " ^ msg))
+  | Ok data -> match Vmm_asn.unikernels_of_cstruct data with
+    | Error (`Msg msg) -> Error (`Msg ("couldn't parse dump file: " ^ msg))
+    | Ok unikernels ->
+      let all = Vmm_trie.all unikernels in
+      Logs.app (fun m -> m "parsed %d unikernels:" (List.length all));
+      List.iter (fun (name, unik) ->
+          Logs.app (fun m -> m "%a: %a" Vmm_core.Name.pp name
+                       Vmm_core.Unikernel.pp_config unik))
+        all;
+      Ok ()
+
+open Cmdliner
+open Albatross_cli
+
+let file =
+  let doc = "File to read the dump from (prefixed by dbdir if relative)" in
+  Arg.(value & opt (some string) None & info [ "file" ] ~doc)
+
+let cmd =
+  Term.(term_result (const jump $ setup_log $ file $ dbdir)),
+  Term.info "albatross-client-inspect-dump" ~version
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

client/dune

@@ -17,4 +17,11 @@
   (public_name albatross-client-remote-tls)
   (package albatross)
   (modules albatross_client_remote_tls)
-  (libraries albatross.cli albatross albatross.tls albatross_tls_cli mirage-crypto-rng.lwt))
+  (libraries albatross.cli albatross albatross.tls albatross_tls_cli))
+
+(executable
+  (name albatross_client_inspect_dump)
+  (public_name albatross-client-inspect-dump)
+  (package albatross)
+  (modules albatross_client_inspect_dump)
+  (libraries albatross.cli albatross))

src/vmm_unix.ml

@@ -96,16 +96,22 @@ let close_no_err fd = try close fd with _ -> ()
 
 let dump, restore =
   let open R.Infix in
-  (fun data ->
-     let state_file = Fpath.(!dbdir / "state") in
+  let state_file ?(name = "state") () =
+    if Fpath.is_seg name then
+      Fpath.(!dbdir / name)
+    else
+      Fpath.v name
+  in
+  (fun ?name data ->
+     let state_file = state_file ?name () in
      Bos.OS.File.exists state_file >>= fun exists ->
      (if exists then begin
         let bak = Fpath.(state_file + "bak") in
         Bos.OS.U.(error_to_msg @@ rename state_file bak)
       end else Ok ()) >>= fun () ->
      Bos.OS.File.write state_file (Cstruct.to_string data)),
-  (fun () ->
-     let state_file = Fpath.(!dbdir / "state") in
+  (fun ?name () ->
+     let state_file = state_file ?name () in
      Bos.OS.File.exists state_file >>= fun exists ->
      if exists then
        Bos.OS.File.read state_file >>| fun data ->

src/vmm_unix.mli

@@ -30,8 +30,8 @@ val destroy_block : Name.t -> (unit, [> R.msg ]) result
 
 val find_block_devices : unit -> ((Name.t * int) list, [> R.msg ]) result
 
-val dump : Cstruct.t -> (unit, [> R.msg ]) result
+val dump : ?name:string -> Cstruct.t -> (unit, [> R.msg ]) result
 
-val restore : unit -> (Cstruct.t, [> R.msg | `NoFile ]) result
+val restore : ?name:string -> unit -> (Cstruct.t, [> R.msg | `NoFile ]) result
 
 val vm_device : Unikernel.t -> (string, [> R.msg ]) result

tls/dune

@@ -16,11 +16,11 @@
   (public_name albatross-tls-endpoint)
   (package albatross)
   (modules albatross_tls_endpoint)
-  (libraries albatross_cli albatross_tls_cli albatross mirage-crypto-rng.lwt))
+  (libraries albatross_cli albatross_tls_cli albatross))
 
 (executable
   (name albatross_tls_inetd)
   (public_name albatross-tls-inetd)
   (package albatross)
   (modules albatross_tls_inetd)
-  (libraries albatross_cli albatross_tls_cli albatross mirage-crypto-rng.lwt))
+  (libraries albatross_cli albatross_tls_cli albatross))