further rng cleanups (remove deps from dune); albatross-client-inspect-dump which reads a state file (for cautious upgrades)
This commit is contained in:
parent
d93a683d94
commit
125711ac6d
30
client/albatross_client_inspect_dump.ml
Normal file
30
client/albatross_client_inspect_dump.ml
Normal file
|
@ -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
|
|
@ -17,4 +17,11 @@
|
||||||
(public_name albatross-client-remote-tls)
|
(public_name albatross-client-remote-tls)
|
||||||
(package albatross)
|
(package albatross)
|
||||||
(modules albatross_client_remote_tls)
|
(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))
|
||||||
|
|
|
@ -96,16 +96,22 @@ let close_no_err fd = try close fd with _ -> ()
|
||||||
|
|
||||||
let dump, restore =
|
let dump, restore =
|
||||||
let open R.Infix in
|
let open R.Infix in
|
||||||
(fun data ->
|
let state_file ?(name = "state") () =
|
||||||
let state_file = Fpath.(!dbdir / "state") in
|
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 ->
|
Bos.OS.File.exists state_file >>= fun exists ->
|
||||||
(if exists then begin
|
(if exists then begin
|
||||||
let bak = Fpath.(state_file + "bak") in
|
let bak = Fpath.(state_file + "bak") in
|
||||||
Bos.OS.U.(error_to_msg @@ rename state_file bak)
|
Bos.OS.U.(error_to_msg @@ rename state_file bak)
|
||||||
end else Ok ()) >>= fun () ->
|
end else Ok ()) >>= fun () ->
|
||||||
Bos.OS.File.write state_file (Cstruct.to_string data)),
|
Bos.OS.File.write state_file (Cstruct.to_string data)),
|
||||||
(fun () ->
|
(fun ?name () ->
|
||||||
let state_file = Fpath.(!dbdir / "state") in
|
let state_file = state_file ?name () in
|
||||||
Bos.OS.File.exists state_file >>= fun exists ->
|
Bos.OS.File.exists state_file >>= fun exists ->
|
||||||
if exists then
|
if exists then
|
||||||
Bos.OS.File.read state_file >>| fun data ->
|
Bos.OS.File.read state_file >>| fun data ->
|
||||||
|
|
|
@ -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 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
|
val vm_device : Unikernel.t -> (string, [> R.msg ]) result
|
||||||
|
|
4
tls/dune
4
tls/dune
|
@ -16,11 +16,11 @@
|
||||||
(public_name albatross-tls-endpoint)
|
(public_name albatross-tls-endpoint)
|
||||||
(package albatross)
|
(package albatross)
|
||||||
(modules albatross_tls_endpoint)
|
(modules albatross_tls_endpoint)
|
||||||
(libraries albatross_cli albatross_tls_cli albatross mirage-crypto-rng.lwt))
|
(libraries albatross_cli albatross_tls_cli albatross))
|
||||||
|
|
||||||
(executable
|
(executable
|
||||||
(name albatross_tls_inetd)
|
(name albatross_tls_inetd)
|
||||||
(public_name albatross-tls-inetd)
|
(public_name albatross-tls-inetd)
|
||||||
(package albatross)
|
(package albatross)
|
||||||
(modules albatross_tls_inetd)
|
(modules albatross_tls_inetd)
|
||||||
(libraries albatross_cli albatross_tls_cli albatross mirage-crypto-rng.lwt))
|
(libraries albatross_cli albatross_tls_cli albatross))
|
||||||
|
|
Loading…
Reference in a new issue