reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Merge pull request #36 from hannesm/more

Browse source 
enhancements in tooling
This commit is contained in:
Hannes Mehnert 2020-07-29 14:14:53 +02:00 committed by GitHub
parent d93a683d94 f7881e24e5
commit 1b1164166b
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 241 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.cirrus.yml
View file

@ -6,7 +6,7 @@ freebsd_task:
matrix:
- OCAML_VERSION: 4.08.1
- 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
dependencies_script: eval `opam env` && opam install -y --deps-only .
build_script: eval `opam env` && dune build

16
client/albatross_client_bistro.ml
View file

@ -115,6 +115,9 @@ let add_policy _ endp cert key ca name vms memory cpus block bridges =
let info_ _ endp cert key ca name =
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 =
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.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 doc = "active policies" in
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.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 ;
destroy_cmd ; create_cmd ;
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ; stats_cmd ; log_cmd ]

30
client/albatross_client_inspect_dump.ml Normal file
View 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

16
client/albatross_client_local.ml
View file

@ -57,6 +57,9 @@ let add_policy _ opt_socket name vms memory cpus block bridges =
let info_ _ opt_socket name =
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 =
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.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 doc = "active policies" in
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.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 ;
destroy_cmd ; create_cmd ;
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ;
stats_subscribe_cmd ; stats_add_cmd ; stats_remove_cmd ; log_cmd ]

9
client/dune
View file

@ -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))

23
command-line/albatross_cli.ml
View file

@ -60,8 +60,29 @@ type exit_status =
let output_result ((_, reply) as wire) =
match reply with
| `Success _ ->
| `Success s ->
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 ()
| `Data _ ->
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire);

3
packaging/FreeBSD/create_package.sh
View file

@ -42,7 +42,8 @@ install -U $bdir/stats/albatross_stat_client.exe $sbindir/albatross_stat_client
for f in albatross_client_local \
albatross_client_remote_tls \
albatross_client_bistro
albatross_client_bistro \
albatross_client_inspect_dump
do install -U $bdir/client/$f.exe $sbindir/$f; done
for f in albatross_provision_ca albatross_provision_request; do

15
provision/albatross_provision_request.ml
View file

@ -35,6 +35,8 @@ let add_policy _ name vms memory cpus block bridges =
let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info)
let get _ name = jump name (`Unikernel_cmd `Unikernel_get)
let destroy _ name =
jump name (`Unikernel_cmd `Unikernel_destroy)
@ -96,6 +98,15 @@ let info_cmd =
Term.(term_result (const info_ $ setup_log $ opt_vm_name)),
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 doc = "active policies" in
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.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 ;
destroy_cmd ; create_cmd ;
info_cmd ; get_cmd ; destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ; stats_cmd ; log_cmd ]

133
src/vmm_asn.ml
View file

@ -1,5 +1,86 @@
(* (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_commands
@ -280,7 +361,7 @@ let log_event =
(sequence2
(required ~label:"name" utf8_string)
(required ~label:"device" utf8_string))))))
(explicit 7 null)))
(explicit 7 null (* placeholder *) )))
let log_cmd =
@ -356,13 +437,7 @@ let v0_unikernel_config =
and fail_behaviour = `Quit (* TODO maybe set to restart by default :) *)
in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g vm =
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)
and g _vm = failwith "cannot encode v0 unikernel configs"
in
Asn.S.map f g @@
Asn.S.(sequence6
@ -373,7 +448,6 @@ let v0_unikernel_config =
(required ~label:"image" image)
(optional ~label:"arguments" (sequence_of utf8_string)))
(* this is part of the state file (and unikernel_create command)
be aware if this (or a dependent grammar) is changed! *)
let v1_unikernel_config =
@ -383,11 +457,7 @@ let v1_unikernel_config =
and block_devices = match blocks with None -> [] | Some xs -> xs
in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g vm =
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))))))))
and g _vm = failwith "cannot encode v1 unikernel configs"
in
Asn.S.(map f g @@ sequence @@
(required ~label:"typ" typ)
@ -430,26 +500,33 @@ let unikernel_config =
let unikernel_cmd =
let f = function
| `C1 () -> `Unikernel_info
| `C2 vm -> `Unikernel_create vm
| `C3 vm -> `Unikernel_force_create vm
| `C4 () -> `Unikernel_destroy
| `C5 vm -> `Unikernel_create vm
| `C6 vm -> `Unikernel_force_create vm
| `C1 `C1 () -> `Unikernel_info
| `C1 `C2 vm -> `Unikernel_create vm
| `C1 `C3 vm -> `Unikernel_force_create vm
| `C1 `C4 () -> `Unikernel_destroy
| `C1 `C5 vm -> `Unikernel_create vm
| `C1 `C6 vm -> `Unikernel_force_create vm
| `C2 `C1 () -> `Unikernel_get
| `C2 `C2 () -> assert false (* placeholder *)
and g = function
| `Unikernel_info -> `C1 ()
| `Unikernel_create vm -> `C5 vm
| `Unikernel_force_create vm -> `C6 vm
| `Unikernel_destroy -> `C4 ()
| `Unikernel_info -> `C1 (`C1 ())
| `Unikernel_create vm -> `C1 (`C5 vm)
| `Unikernel_force_create vm -> `C1 (`C6 vm)
| `Unikernel_destroy -> `C1 (`C4 ())
| `Unikernel_get -> `C2 (`C1 ())
in
Asn.S.map f g @@
Asn.S.(choice6
Asn.S.(choice2
(choice6
(explicit 0 null)
(explicit 1 v1_unikernel_config)
(explicit 2 v1_unikernel_config)
(explicit 3 null)
(explicit 4 unikernel_config)
(explicit 5 unikernel_config))
(choice2
(explicit 6 null)
(explicit 7 null (* placeholder *) )))
let policy_cmd =
let f = function
@ -621,9 +698,9 @@ let log_entry =
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
(* data is persisted to disk, we need to ensure to be able to decode (and
encode) properly without conflicts! *)
let log_disk =
(* data is persisted to disk, we need to ensure to be able to decode (and
encode) properly without conflicts! *)
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"entry" log_entry))
@ -689,6 +766,8 @@ let unikernels =
let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
let cert_extension =
(* note that subCAs are deployed out there, thus modifying the encoding of
commands may break them. *)
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"command" wire_command))

2
src/vmm_commands.ml
View file

@ -61,6 +61,7 @@ type unikernel_cmd = [
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
| `Unikernel_get
]
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_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
| `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
| `Unikernel_get -> Fmt.string ppf "unikernel get"
type policy_cmd = [
| `Policy_info

1
src/vmm_commands.mli
View file

@ -35,6 +35,7 @@ type unikernel_cmd = [
| `Unikernel_create of Unikernel.config
| `Unikernel_force_create of Unikernel.config
| `Unikernel_destroy
| `Unikernel_get
]
type policy_cmd = [

14
src/vmm_unix.ml
View file

@ -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 ->

4
src/vmm_unix.mli
View file

@ -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

7
src/vmm_vmmd.ml
View file

@ -236,6 +236,13 @@ let handle_unikernel_cmd t id = function
| _ ->
Ok (t, `End (`Success (`Unikernels vms)))
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_force_create vm_config ->
begin

4
tls/dune
View file

@ -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))