Merge pull request #36 from hannesm/more

enhancements in tooling

.cirrus.yml

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

client/albatross_client_bistro.ml

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

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/albatross_client_local.ml

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

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

command-line/albatross_cli.ml

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

packaging/FreeBSD/create_package.sh

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

provision/albatross_provision_request.ml

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

src/vmm_asn.ml

@@ -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
-           (explicit 0 null)
-           (explicit 1 v1_unikernel_config)
-           (explicit 2 v1_unikernel_config)
-           (explicit 3 null)
-           (explicit 4 unikernel_config)
-           (explicit 5 unikernel_config))
+  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))
@@ -671,7 +748,7 @@ let version1_unikernels = trie v1_unikernel_config
 let version2_unikernels = trie unikernel_config
 
 let unikernels =
-   (* the choice is the implicit version + migration... be aware when
+  (* the choice is the implicit version + migration... be aware when
      any dependent data layout changes .oO(/o\) *)
   let f = function
     | `C1 data -> data
@@ -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))

src/vmm_commands.ml

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

src/vmm_commands.mli

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

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

src/vmm_vmmd.ml

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

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