From 125711ac6d63a237d8d0f6558b24991cc2fe0080 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Sun, 5 Jul 2020 20:39:29 +0200
Subject: [PATCH] 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 | 30 +++++++++++++++++++++++++
 client/dune                             |  9 +++++++-
 src/vmm_unix.ml                         | 14 ++++++++----
 src/vmm_unix.mli                        |  4 ++--
 tls/dune                                |  4 ++--
 5 files changed, 52 insertions(+), 9 deletions(-)
 create mode 100644 client/albatross_client_inspect_dump.ml

diff --git a/client/albatross_client_inspect_dump.ml b/client/albatross_client_inspect_dump.ml
new file mode 100644
index 0000000..b802790
--- /dev/null
+++ b/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
diff --git a/client/dune b/client/dune
index c14e1ac..5312010 100644
--- a/client/dune
+++ b/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))
diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index fa72603..4491c45 100644
--- a/src/vmm_unix.ml
+++ b/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 ->
diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli
index 638de2e..837c8f5 100644
--- a/src/vmm_unix.mli
+++ b/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
diff --git a/tls/dune b/tls/dune
index d706c1c..b7e989d 100644
--- a/tls/dune
+++ b/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))