commit
1b1164166b
|
@ -6,7 +6,7 @@ freebsd_task:
|
||||||
matrix:
|
matrix:
|
||||||
- OCAML_VERSION: 4.08.1
|
- OCAML_VERSION: 4.08.1
|
||||||
- OCAML_VERSION: 4.09.0
|
- OCAML_VERSION: 4.09.0
|
||||||
pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf
|
pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash
|
||||||
ocaml_script: opam init -a --comp=$OCAML_VERSION
|
ocaml_script: opam init -a --comp=$OCAML_VERSION
|
||||||
dependencies_script: eval `opam env` && opam install -y --deps-only .
|
dependencies_script: eval `opam env` && opam install -y --deps-only .
|
||||||
build_script: eval `opam env` && dune build
|
build_script: eval `opam env` && dune build
|
||||||
|
|
|
@ -115,6 +115,9 @@ let add_policy _ endp cert key ca name vms memory cpus block bridges =
|
||||||
let info_ _ endp cert key ca name =
|
let info_ _ endp cert key ca name =
|
||||||
jump endp cert key ca name (`Unikernel_cmd `Unikernel_info)
|
jump endp cert key ca name (`Unikernel_cmd `Unikernel_info)
|
||||||
|
|
||||||
|
let get _ endp cert key ca name =
|
||||||
|
jump endp cert key ca name (`Unikernel_cmd `Unikernel_get)
|
||||||
|
|
||||||
let destroy _ endp cert key ca name =
|
let destroy _ endp cert key ca name =
|
||||||
jump endp cert key ca name (`Unikernel_cmd `Unikernel_destroy)
|
jump endp cert key ca name (`Unikernel_cmd `Unikernel_destroy)
|
||||||
|
|
||||||
|
@ -197,6 +200,15 @@ let info_cmd =
|
||||||
Term.(const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
|
Term.(const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name),
|
||||||
Term.info "info" ~doc ~man ~exits
|
Term.info "info" ~doc ~man ~exits
|
||||||
|
|
||||||
|
let get_cmd =
|
||||||
|
let doc = "retrieve a VM" in
|
||||||
|
let man =
|
||||||
|
[`S "DESCRIPTION";
|
||||||
|
`P "Downloads a VM."]
|
||||||
|
in
|
||||||
|
Term.(const get $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name),
|
||||||
|
Term.info "get" ~doc ~man ~exits
|
||||||
|
|
||||||
let policy_cmd =
|
let policy_cmd =
|
||||||
let doc = "active policies" in
|
let doc = "active policies" in
|
||||||
let man =
|
let man =
|
||||||
|
@ -300,9 +312,9 @@ let default_cmd =
|
||||||
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
||||||
Term.info "albatross_client_bistro" ~version ~doc ~man ~exits
|
Term.info "albatross_client_bistro" ~version ~doc ~man ~exits
|
||||||
|
|
||||||
let cmds = [ help_cmd ; info_cmd ;
|
let cmds = [ help_cmd ;
|
||||||
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
||||||
destroy_cmd ; create_cmd ;
|
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
|
||||||
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
||||||
console_cmd ; stats_cmd ; log_cmd ]
|
console_cmd ; stats_cmd ; log_cmd ]
|
||||||
|
|
||||||
|
|
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
|
|
@ -57,6 +57,9 @@ let add_policy _ opt_socket name vms memory cpus block bridges =
|
||||||
let info_ _ opt_socket name =
|
let info_ _ opt_socket name =
|
||||||
jump opt_socket name (`Unikernel_cmd `Unikernel_info)
|
jump opt_socket name (`Unikernel_cmd `Unikernel_info)
|
||||||
|
|
||||||
|
let get _ opt_socket name =
|
||||||
|
jump opt_socket name (`Unikernel_cmd `Unikernel_get)
|
||||||
|
|
||||||
let destroy _ opt_socket name =
|
let destroy _ opt_socket name =
|
||||||
jump opt_socket name (`Unikernel_cmd `Unikernel_destroy)
|
jump opt_socket name (`Unikernel_cmd `Unikernel_destroy)
|
||||||
|
|
||||||
|
@ -131,6 +134,15 @@ let info_cmd =
|
||||||
Term.(term_result (const info_ $ setup_log $ socket $ opt_vm_name $ tmpdir)),
|
Term.(term_result (const info_ $ setup_log $ socket $ opt_vm_name $ tmpdir)),
|
||||||
Term.info "info" ~doc ~man ~exits
|
Term.info "info" ~doc ~man ~exits
|
||||||
|
|
||||||
|
let get_cmd =
|
||||||
|
let doc = "retrieve a VM" in
|
||||||
|
let man =
|
||||||
|
[`S "DESCRIPTION";
|
||||||
|
`P "Downloads a VM."]
|
||||||
|
in
|
||||||
|
Term.(term_result (const get $ setup_log $ socket $ vm_name $ tmpdir)),
|
||||||
|
Term.info "get" ~doc ~man ~exits
|
||||||
|
|
||||||
let policy_cmd =
|
let policy_cmd =
|
||||||
let doc = "active policies" in
|
let doc = "active policies" in
|
||||||
let man =
|
let man =
|
||||||
|
@ -252,9 +264,9 @@ let default_cmd =
|
||||||
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
||||||
Term.info "albatross_client_local" ~version ~doc ~man ~exits
|
Term.info "albatross_client_local" ~version ~doc ~man ~exits
|
||||||
|
|
||||||
let cmds = [ help_cmd ; info_cmd ;
|
let cmds = [ help_cmd ;
|
||||||
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
||||||
destroy_cmd ; create_cmd ;
|
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
|
||||||
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
||||||
console_cmd ;
|
console_cmd ;
|
||||||
stats_subscribe_cmd ; stats_add_cmd ; stats_remove_cmd ; log_cmd ]
|
stats_subscribe_cmd ; stats_add_cmd ; stats_remove_cmd ; log_cmd ]
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -60,8 +60,29 @@ type exit_status =
|
||||||
|
|
||||||
let output_result ((_, reply) as wire) =
|
let output_result ((_, reply) as wire) =
|
||||||
match reply with
|
match reply with
|
||||||
| `Success _ ->
|
| `Success s ->
|
||||||
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
|
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
|
||||||
|
begin match s with
|
||||||
|
| `Unikernels vms ->
|
||||||
|
List.iter (fun (name, cfg) ->
|
||||||
|
if Cstruct.len cfg.Unikernel.image > 0 then
|
||||||
|
let filename =
|
||||||
|
let ts = Ptime.to_rfc3339 (Ptime_clock.now ()) in
|
||||||
|
Fpath.(v (Filename.get_temp_dir_name ()) / Name.to_string name + ts)
|
||||||
|
in
|
||||||
|
let write data =
|
||||||
|
match Bos.OS.File.write filename data with
|
||||||
|
| Ok () -> Logs.app (fun m -> m "dumped image to %a" Fpath.pp filename)
|
||||||
|
| Error (`Msg msg) -> Logs.err (fun m -> m "failed to write image: %s" msg)
|
||||||
|
in
|
||||||
|
if cfg.Unikernel.compressed then
|
||||||
|
match Vmm_compress.uncompress (Cstruct.to_string cfg.Unikernel.image) with
|
||||||
|
| Ok blob -> write blob
|
||||||
|
| Error () -> Logs.err (fun m -> m "failed to uncompress unikernel image")
|
||||||
|
else
|
||||||
|
write (Cstruct.to_string cfg.Unikernel.image)) vms
|
||||||
|
| _ -> ()
|
||||||
|
end;
|
||||||
Ok ()
|
Ok ()
|
||||||
| `Data _ ->
|
| `Data _ ->
|
||||||
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
|
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);
|
||||||
|
|
|
@ -42,7 +42,8 @@ install -U $bdir/stats/albatross_stat_client.exe $sbindir/albatross_stat_client
|
||||||
|
|
||||||
for f in albatross_client_local \
|
for f in albatross_client_local \
|
||||||
albatross_client_remote_tls \
|
albatross_client_remote_tls \
|
||||||
albatross_client_bistro
|
albatross_client_bistro \
|
||||||
|
albatross_client_inspect_dump
|
||||||
do install -U $bdir/client/$f.exe $sbindir/$f; done
|
do install -U $bdir/client/$f.exe $sbindir/$f; done
|
||||||
|
|
||||||
for f in albatross_provision_ca albatross_provision_request; do
|
for f in albatross_provision_ca albatross_provision_request; do
|
||||||
|
|
|
@ -35,6 +35,8 @@ let add_policy _ name vms memory cpus block bridges =
|
||||||
|
|
||||||
let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info)
|
let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info)
|
||||||
|
|
||||||
|
let get _ name = jump name (`Unikernel_cmd `Unikernel_get)
|
||||||
|
|
||||||
let destroy _ name =
|
let destroy _ name =
|
||||||
jump name (`Unikernel_cmd `Unikernel_destroy)
|
jump name (`Unikernel_cmd `Unikernel_destroy)
|
||||||
|
|
||||||
|
@ -96,6 +98,15 @@ let info_cmd =
|
||||||
Term.(term_result (const info_ $ setup_log $ opt_vm_name)),
|
Term.(term_result (const info_ $ setup_log $ opt_vm_name)),
|
||||||
Term.info "info" ~doc ~man
|
Term.info "info" ~doc ~man
|
||||||
|
|
||||||
|
let get_cmd =
|
||||||
|
let doc = "retrieve a VM" in
|
||||||
|
let man =
|
||||||
|
[`S "DESCRIPTION";
|
||||||
|
`P "Downloads a VM."]
|
||||||
|
in
|
||||||
|
Term.(term_result (const get $ setup_log $ vm_name)),
|
||||||
|
Term.info "get" ~doc ~man ~exits
|
||||||
|
|
||||||
let policy_cmd =
|
let policy_cmd =
|
||||||
let doc = "active policies" in
|
let doc = "active policies" in
|
||||||
let man =
|
let man =
|
||||||
|
@ -199,9 +210,9 @@ let default_cmd =
|
||||||
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
|
||||||
Term.info "albatross_provision_request" ~version ~doc ~man
|
Term.info "albatross_provision_request" ~version ~doc ~man
|
||||||
|
|
||||||
let cmds = [ help_cmd ; info_cmd ;
|
let cmds = [ help_cmd ;
|
||||||
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
|
||||||
destroy_cmd ; create_cmd ;
|
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
|
||||||
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
|
||||||
console_cmd ; stats_cmd ; log_cmd ]
|
console_cmd ; stats_cmd ; log_cmd ]
|
||||||
|
|
||||||
|
|
131
src/vmm_asn.ml
131
src/vmm_asn.ml
|
@ -1,5 +1,86 @@
|
||||||
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
||||||
|
|
||||||
|
(* please read this before changing this module:
|
||||||
|
|
||||||
|
Data encoded by this module is persisted in (a) log entry (b) dump file
|
||||||
|
(c) certificates (and subCA). It is important to be aware of backward and
|
||||||
|
forward compatibility when modifying this module. There are various version
|
||||||
|
fields around which are mostly useless in retrospect. On a server deployment,
|
||||||
|
upgrades are supported while downgrades are not (there could be a separate
|
||||||
|
tool reading newer data and dumping it for older albatross versions). The
|
||||||
|
assumption is that a server deployment moves forward. For the clients, older
|
||||||
|
clients should best be support smoothly, or an error from the server should
|
||||||
|
be issued informing about a too old version. Clients which support newer
|
||||||
|
wire version should as well be notified (it may be suitable to have a
|
||||||
|
--use-version command-line flag - so new clients can talk to old servers).
|
||||||
|
|
||||||
|
The log (a) is append-only, whenever a new log entry is added, the choice
|
||||||
|
log_entry should be extended. New entries just use the new choice. The dump
|
||||||
|
on disk (dumped via log_to_disk, restored logs_of_disk) prepends a (rather
|
||||||
|
useless) version field. Restoring a new log entry with an old albatross_log
|
||||||
|
will result in a warning (but restores the other log entries).
|
||||||
|
|
||||||
|
It should be ensured that old unikernels dumped to disk (b) can be read by
|
||||||
|
new albatross daemons. The functions unikernels_to_cstruct and
|
||||||
|
unikernels_of_cstruct 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.
|
||||||
|
|
||||||
|
The data in transit (certificates and commands) is out of control of a single
|
||||||
|
operator. This means that best effort should be done to support old clients
|
||||||
|
(and old servers - eventually with a command-line argument --use-version). If
|
||||||
|
a server receives a command (via TLS cert_extension), this is prefixed by a
|
||||||
|
version. The non-TLS command is a sequence of header and payload, where the
|
||||||
|
header includes a version. At the moment, the commands are all explicit
|
||||||
|
choices, adding new ones by extending the choice works in a
|
||||||
|
backwards-compatible way.
|
||||||
|
*)
|
||||||
|
|
||||||
|
(* The version field could be used (at the moment, decoding a newer version
|
||||||
|
leads to a decoding failure):
|
||||||
|
|
||||||
|
Now, to achieve version-dependent parsing, what is missing is a way to decode
|
||||||
|
the first element of a sequence only (i.e. treat the second element as
|
||||||
|
"any"). This is something missing for PKCS12 from the asn1 library. A
|
||||||
|
"quick hack" is to extract length information of the first element, and use
|
||||||
|
that decoder on the sub-buffer. The following implements this.
|
||||||
|
|
||||||
|
let seq_hd cs =
|
||||||
|
(* we assume a ASN.1 DER/BER encoded sequence starting in cs:
|
||||||
|
- 0x30
|
||||||
|
- length (definite length field - not 0x80)
|
||||||
|
- <data> (of length length)
|
||||||
|
|
||||||
|
retrieve data to decode only the first element: <data>, which is cs offset
|
||||||
|
(at least 2, 0x30 0xLL), and length encoded before
|
||||||
|
*)
|
||||||
|
guard (Cstruct.len cs > 2) (`Msg "too short") >>= fun () ->
|
||||||
|
guard (Cstruct.get_uint8 cs 0 = 0x30) (`Msg "not a sequence") >>= fun () ->
|
||||||
|
let l1 = Cstruct.get_uint8 cs 1 in
|
||||||
|
(if l1 < 0x80 then
|
||||||
|
Ok (2, l1)
|
||||||
|
else if l1 = 0x80 then
|
||||||
|
Error (`Msg "indefinite length")
|
||||||
|
else
|
||||||
|
let octets = l1 land 0x7F in
|
||||||
|
guard (Cstruct.len cs > octets + 2) (`Msg "data too short") >>= fun () ->
|
||||||
|
let rec go off acc =
|
||||||
|
if off = octets then
|
||||||
|
Ok (2 + octets, acc)
|
||||||
|
else
|
||||||
|
go (succ off) (Cstruct.get_uint8 cs (off + 2) + acc lsl 8)
|
||||||
|
in
|
||||||
|
go 0 0) >>= fun (off, l) ->
|
||||||
|
guard (Cstruct.len cs >= l + off) (`Msg "buffer too small") >>= fun () ->
|
||||||
|
Ok (Cstruct.sub cs off l)
|
||||||
|
|
||||||
|
let decode_version cs =
|
||||||
|
let c = Asn.codec Asn.der version in
|
||||||
|
match Asn.decode c cs with
|
||||||
|
| Ok (a, _) -> Ok a
|
||||||
|
| Error (`Parse msg) -> Error (`Msg msg)
|
||||||
|
*)
|
||||||
|
|
||||||
open Vmm_core
|
open Vmm_core
|
||||||
open Vmm_commands
|
open Vmm_commands
|
||||||
|
|
||||||
|
@ -280,7 +361,7 @@ let log_event =
|
||||||
(sequence2
|
(sequence2
|
||||||
(required ~label:"name" utf8_string)
|
(required ~label:"name" utf8_string)
|
||||||
(required ~label:"device" utf8_string))))))
|
(required ~label:"device" utf8_string))))))
|
||||||
(explicit 7 null)))
|
(explicit 7 null (* placeholder *) )))
|
||||||
|
|
||||||
|
|
||||||
let log_cmd =
|
let log_cmd =
|
||||||
|
@ -356,13 +437,7 @@ let v0_unikernel_config =
|
||||||
and fail_behaviour = `Quit (* TODO maybe set to restart by default :) *)
|
and fail_behaviour = `Quit (* TODO maybe set to restart by default :) *)
|
||||||
in
|
in
|
||||||
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
|
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
|
||||||
and g vm =
|
and g _vm = failwith "cannot encode v0 unikernel configs"
|
||||||
let network_interfaces = match vm.bridges with [] -> None | xs -> Some (List.map fst xs)
|
|
||||||
and block_device = match vm.block_devices with [] -> None | x::_ -> Some x
|
|
||||||
and typ = if vm.compressed then `Hvt_amd64_compressed else `Hvt_amd64
|
|
||||||
in
|
|
||||||
let image = typ, vm.image in
|
|
||||||
(vm.cpuid, vm.memory, block_device, network_interfaces, image, vm.argv)
|
|
||||||
in
|
in
|
||||||
Asn.S.map f g @@
|
Asn.S.map f g @@
|
||||||
Asn.S.(sequence6
|
Asn.S.(sequence6
|
||||||
|
@ -373,7 +448,6 @@ let v0_unikernel_config =
|
||||||
(required ~label:"image" image)
|
(required ~label:"image" image)
|
||||||
(optional ~label:"arguments" (sequence_of utf8_string)))
|
(optional ~label:"arguments" (sequence_of utf8_string)))
|
||||||
|
|
||||||
|
|
||||||
(* this is part of the state file (and unikernel_create command)
|
(* this is part of the state file (and unikernel_create command)
|
||||||
be aware if this (or a dependent grammar) is changed! *)
|
be aware if this (or a dependent grammar) is changed! *)
|
||||||
let v1_unikernel_config =
|
let v1_unikernel_config =
|
||||||
|
@ -383,11 +457,7 @@ let v1_unikernel_config =
|
||||||
and block_devices = match blocks with None -> [] | Some xs -> xs
|
and block_devices = match blocks with None -> [] | Some xs -> xs
|
||||||
in
|
in
|
||||||
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
|
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
|
||||||
and g vm =
|
and g _vm = failwith "cannot encode v1 unikernel configs"
|
||||||
let bridges = match vm.bridges with [] -> None | xs -> Some (List.map fst xs)
|
|
||||||
and blocks = match vm.block_devices with [] -> None | xs -> Some xs
|
|
||||||
in
|
|
||||||
(vm.typ, (vm.compressed, (vm.image, (vm.fail_behaviour, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))))
|
|
||||||
in
|
in
|
||||||
Asn.S.(map f g @@ sequence @@
|
Asn.S.(map f g @@ sequence @@
|
||||||
(required ~label:"typ" typ)
|
(required ~label:"typ" typ)
|
||||||
|
@ -430,26 +500,33 @@ let unikernel_config =
|
||||||
|
|
||||||
let unikernel_cmd =
|
let unikernel_cmd =
|
||||||
let f = function
|
let f = function
|
||||||
| `C1 () -> `Unikernel_info
|
| `C1 `C1 () -> `Unikernel_info
|
||||||
| `C2 vm -> `Unikernel_create vm
|
| `C1 `C2 vm -> `Unikernel_create vm
|
||||||
| `C3 vm -> `Unikernel_force_create vm
|
| `C1 `C3 vm -> `Unikernel_force_create vm
|
||||||
| `C4 () -> `Unikernel_destroy
|
| `C1 `C4 () -> `Unikernel_destroy
|
||||||
| `C5 vm -> `Unikernel_create vm
|
| `C1 `C5 vm -> `Unikernel_create vm
|
||||||
| `C6 vm -> `Unikernel_force_create vm
|
| `C1 `C6 vm -> `Unikernel_force_create vm
|
||||||
|
| `C2 `C1 () -> `Unikernel_get
|
||||||
|
| `C2 `C2 () -> assert false (* placeholder *)
|
||||||
and g = function
|
and g = function
|
||||||
| `Unikernel_info -> `C1 ()
|
| `Unikernel_info -> `C1 (`C1 ())
|
||||||
| `Unikernel_create vm -> `C5 vm
|
| `Unikernel_create vm -> `C1 (`C5 vm)
|
||||||
| `Unikernel_force_create vm -> `C6 vm
|
| `Unikernel_force_create vm -> `C1 (`C6 vm)
|
||||||
| `Unikernel_destroy -> `C4 ()
|
| `Unikernel_destroy -> `C1 (`C4 ())
|
||||||
|
| `Unikernel_get -> `C2 (`C1 ())
|
||||||
in
|
in
|
||||||
Asn.S.map f g @@
|
Asn.S.map f g @@
|
||||||
Asn.S.(choice6
|
Asn.S.(choice2
|
||||||
|
(choice6
|
||||||
(explicit 0 null)
|
(explicit 0 null)
|
||||||
(explicit 1 v1_unikernel_config)
|
(explicit 1 v1_unikernel_config)
|
||||||
(explicit 2 v1_unikernel_config)
|
(explicit 2 v1_unikernel_config)
|
||||||
(explicit 3 null)
|
(explicit 3 null)
|
||||||
(explicit 4 unikernel_config)
|
(explicit 4 unikernel_config)
|
||||||
(explicit 5 unikernel_config))
|
(explicit 5 unikernel_config))
|
||||||
|
(choice2
|
||||||
|
(explicit 6 null)
|
||||||
|
(explicit 7 null (* placeholder *) )))
|
||||||
|
|
||||||
let policy_cmd =
|
let policy_cmd =
|
||||||
let f = function
|
let f = function
|
||||||
|
@ -621,9 +698,9 @@ let log_entry =
|
||||||
|
|
||||||
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
|
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
|
||||||
|
|
||||||
|
let log_disk =
|
||||||
(* data is persisted to disk, we need to ensure to be able to decode (and
|
(* data is persisted to disk, we need to ensure to be able to decode (and
|
||||||
encode) properly without conflicts! *)
|
encode) properly without conflicts! *)
|
||||||
let log_disk =
|
|
||||||
Asn.S.(sequence2
|
Asn.S.(sequence2
|
||||||
(required ~label:"version" version)
|
(required ~label:"version" version)
|
||||||
(required ~label:"entry" log_entry))
|
(required ~label:"entry" log_entry))
|
||||||
|
@ -689,6 +766,8 @@ let unikernels =
|
||||||
let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
|
let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
|
||||||
|
|
||||||
let cert_extension =
|
let cert_extension =
|
||||||
|
(* note that subCAs are deployed out there, thus modifying the encoding of
|
||||||
|
commands may break them. *)
|
||||||
Asn.S.(sequence2
|
Asn.S.(sequence2
|
||||||
(required ~label:"version" version)
|
(required ~label:"version" version)
|
||||||
(required ~label:"command" wire_command))
|
(required ~label:"command" wire_command))
|
||||||
|
|
|
@ -61,6 +61,7 @@ type unikernel_cmd = [
|
||||||
| `Unikernel_create of Unikernel.config
|
| `Unikernel_create of Unikernel.config
|
||||||
| `Unikernel_force_create of Unikernel.config
|
| `Unikernel_force_create of Unikernel.config
|
||||||
| `Unikernel_destroy
|
| `Unikernel_destroy
|
||||||
|
| `Unikernel_get
|
||||||
]
|
]
|
||||||
|
|
||||||
let pp_unikernel_cmd ppf = function
|
let pp_unikernel_cmd ppf = function
|
||||||
|
@ -68,6 +69,7 @@ let pp_unikernel_cmd ppf = function
|
||||||
| `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config
|
| `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config
|
||||||
| `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
|
| `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
|
||||||
| `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
|
| `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
|
||||||
|
| `Unikernel_get -> Fmt.string ppf "unikernel get"
|
||||||
|
|
||||||
type policy_cmd = [
|
type policy_cmd = [
|
||||||
| `Policy_info
|
| `Policy_info
|
||||||
|
|
|
@ -35,6 +35,7 @@ type unikernel_cmd = [
|
||||||
| `Unikernel_create of Unikernel.config
|
| `Unikernel_create of Unikernel.config
|
||||||
| `Unikernel_force_create of Unikernel.config
|
| `Unikernel_force_create of Unikernel.config
|
||||||
| `Unikernel_destroy
|
| `Unikernel_destroy
|
||||||
|
| `Unikernel_get
|
||||||
]
|
]
|
||||||
|
|
||||||
type policy_cmd = [
|
type policy_cmd = [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -236,6 +236,13 @@ let handle_unikernel_cmd t id = function
|
||||||
| _ ->
|
| _ ->
|
||||||
Ok (t, `End (`Success (`Unikernels vms)))
|
Ok (t, `End (`Success (`Unikernels vms)))
|
||||||
end
|
end
|
||||||
|
| `Unikernel_get ->
|
||||||
|
Logs.debug (fun m -> m "get %a" Name.pp id) ;
|
||||||
|
begin match Vmm_trie.find id t.resources.Vmm_resources.unikernels with
|
||||||
|
| None -> Error (`Msg "get: no unikernel found")
|
||||||
|
| Some u ->
|
||||||
|
Ok (t, `End (`Success (`Unikernels [ (id, u.Unikernel.config) ])))
|
||||||
|
end
|
||||||
| `Unikernel_create vm_config -> Ok (t, `Create (id, vm_config))
|
| `Unikernel_create vm_config -> Ok (t, `Create (id, vm_config))
|
||||||
| `Unikernel_force_create vm_config ->
|
| `Unikernel_force_create vm_config ->
|
||||||
begin
|
begin
|
||||||
|
|
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