revise tag and compression in unikernel config

command-line/albatross_cli.ml

@@ -82,15 +82,15 @@ let setup_log style_renderer level =
 let create_vm force image cpuid memory argv block_devices bridges compression restart_on_fail =
   let open Rresult.R.Infix in
   Bos.OS.File.read (Fpath.v image) >>| fun image ->
-  let image = match compression with
+  let image, compressed = match compression with
-    | 0 -> `Hvt_amd64, Cstruct.of_string image
+    | 0 -> Cstruct.of_string image, false
     | level ->
       let img = Vmm_compress.compress ~level image in
-      `Hvt_amd64_compressed, Cstruct.of_string img
+      Cstruct.of_string img, true
   and argv = match argv with [] -> None | xs -> Some xs
   and fail_behaviour = if restart_on_fail then `Restart else `Quit
   in
-  let config = Unikernel.{ cpuid ; memory ; block_devices ; bridges ; argv ; image ; fail_behaviour } in
+  let config = Unikernel.{ typ = `Solo5 ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv } in
   if force then `Unikernel_force_create config else `Unikernel_create config
 
 let policy vms memory cpus block bridges =

src/vmm_asn.ml

@@ -50,22 +50,6 @@ let policy =
            (optional ~label:"block" int)
            (required ~label:"bridges" Asn.S.(sequence_of utf8_string)))
 
-let image =
-  let f = function
-    | `C1 x -> `Hvt_amd64, x
-    | `C2 x -> `Hvt_arm64, x
-    | `C3 x -> `Hvt_amd64_compressed, x
-  and g = function
-    | `Hvt_amd64, x -> `C1 x
-    | `Hvt_arm64, x -> `C2 x
-    | `Hvt_amd64_compressed, x -> `C3 x
-  in
-  Asn.S.map f g @@
-  Asn.S.(choice3
-           (explicit 0 octet_string)
-           (explicit 1 octet_string)
-           (explicit 2 octet_string))
-
 let console_cmd =
   let f = function
     | `C1 () -> `Console_add
@@ -282,6 +266,16 @@ let log_cmd =
   Asn.S.map f g @@
   Asn.S.(sequence (single (optional ~label:"since" utc_time)))
 
+let typ =
+  let f = function
+    | `C1 () -> `Solo5
+    | `C2 () -> assert false
+  and g = function
+    | `Solo5 -> `C1 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice2 (explicit 0 null) (explicit 1 null))
+
 let fail_behaviour =
   let f = function
     | `C1 () -> `Quit
@@ -297,21 +291,23 @@ let fail_behaviour =
 
 let unikernel_config =
   let open Unikernel in
-  let f (fail_behaviour, (image, (cpuid, (memory, (blocks, (bridges, argv)))))) =
+  let f (typ, (compressed, (image, (fail_behaviour, (cpuid, (memory, (blocks, (bridges, argv)))))))) =
     let bridges = match bridges with None -> [] | Some xs -> xs
     and block_devices = match blocks with None -> [] | Some xs -> xs
     in
-    { cpuid ; memory ; block_devices ; bridges ; image ; argv ; fail_behaviour }
+    { typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
   and g vm =
     let bridges = match vm.bridges with [] -> None | xs -> Some xs
     and blocks = match vm.block_devices with [] -> None | xs -> Some xs
     in
-    (vm.fail_behaviour, (vm.image, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))
+    (vm.typ, (vm.compressed, (vm.image, (vm.fail_behaviour, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))))
   in
   Asn.S.(map f g @@ sequence @@
-           (required ~label:"fail behaviour" (explicit 3 fail_behaviour))
+           (required ~label:"typ" typ)
-         @ (required ~label:"image" image)
+         @ (required ~label:"compressed" bool)
-         @ (required ~label:"cpu" int)
+         @ (required ~label:"image" octet_string)
+         @ (required ~label:"fail behaviour" fail_behaviour)
+         @ (required ~label:"cpuid" int)
          @ (required ~label:"memory" int)
          @ (optional ~label:"blocks" (explicit 0 (sequence_of utf8_string)))
          @ (optional ~label:"bridges" (explicit 1 (sequence_of utf8_string)))

src/vmm_core.ml

@@ -151,12 +151,10 @@ module Policy = struct
 end
 
 module Unikernel = struct
-  type typ = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
+  type typ = [ `Solo5 ]
 
   let pp_typ ppf = function
-    | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
+    | `Solo5 -> Fmt.pf ppf "solo5"
-    | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
-    | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
 
   type fail_behaviour = [ `Quit | `Restart ]
 
@@ -164,26 +162,26 @@ module Unikernel = struct
     Fmt.string ppf (match f with `Quit -> "quit" | `Restart -> "restart")
 
   type config = {
+    typ : typ ;
+    compressed : bool ;
+    image : Cstruct.t ;
+    fail_behaviour : fail_behaviour;
     cpuid : int ;
     memory : int ;
     block_devices : string list ;
     bridges : string list ;
-    image : typ * Cstruct.t ;
     argv : string list option ;
-    fail_behaviour : fail_behaviour;
   }
 
-  let pp_image ppf (typ, blob) =
-    let l = Cstruct.len blob in
-    Fmt.pf ppf "%a: %d bytes" pp_typ typ l
-
   let pp_config ppf (vm : config) =
-    Fmt.pf ppf "fail behaviour %a, cpu %d, %d MB memory, block devices %a@ bridge %a, image %a, argv %a"
+    Fmt.pf ppf "typ %a@ compression %B image %d bytes@ fail behaviour %a@ cpu %d@ %d MB memory@ block devices %a@ bridge %a@ argv %a"
+      pp_typ vm.typ
+      vm.compressed
+      (Cstruct.len vm.image)
       pp_fail_behaviour vm.fail_behaviour
       vm.cpuid vm.memory
       Fmt.(list ~sep:(unit ", ") string) vm.block_devices
       Fmt.(list ~sep:(unit ", ") string) vm.bridges
-      pp_image vm.image
       Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv
 
   type t = {

src/vmm_core.mli

@@ -55,23 +55,23 @@ module Policy : sig
 end
 
 module Unikernel : sig
-  type typ = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
+  type typ = [ `Solo5 ]
   val pp_typ : typ Fmt.t
 
   type fail_behaviour = [ `Quit | `Restart ]
 
   type config = {
+    typ : typ ;
+    compressed : bool ;
+    image : Cstruct.t ;
+    fail_behaviour : fail_behaviour;
     cpuid : int ;
     memory : int ;
     block_devices : string list ;
     bridges : string list ;
-    image : typ * Cstruct.t;
     argv : string list option ;
-    fail_behaviour : fail_behaviour;
   }
 
-  val pp_image : (typ * Cstruct.t) Fmt.t
-
   val pp_config : config Fmt.t
 
   type t = {

src/vmm_unix.ml

@@ -125,14 +125,15 @@ let destroy_tap tapname =
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
 let prepare name vm =
-  (match vm.Unikernel.image with
+  (match vm.Unikernel.typ with
-   | `Hvt_amd64, blob -> Ok blob
+   | `Solo5 ->
-   | `Hvt_amd64_compressed, blob ->
+     if vm.Unikernel.compressed then
-     begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
+       begin match Vmm_compress.uncompress (Cstruct.to_string vm.Unikernel.image) with
          | Ok blob -> Ok (Cstruct.of_string blob)
          | Error () -> Error (`Msg "failed to uncompress")
        end
-   | `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
+     else
+       Ok vm.Unikernel.image) >>= fun image ->
   let fifo = Name.fifo_file name in
   (match fifo_exists fifo with
    | Ok true -> Ok ()