check manifest with provided device arguments

command-line/albatross_cli.ml

@@ -102,7 +102,9 @@ let setup_log style_renderer level =
 
 let create_vm force image cpuid memory argv block_devices bridges compression restart_on_fail exit_codes =
   let open Rresult.R.Infix in
-  Bos.OS.File.read (Fpath.v image) >>| fun image ->
+  let img_file = Fpath.v image in
+  Bos.OS.File.read img_file >>= fun image ->
+  Vmm_unix.manifest_devices_match ~bridges ~block_devices img_file >>| fun () ->
   let image, compressed = match compression with
     | 0 -> Cstruct.of_string image, false
     | level ->

src/vmm_json.ml

@@ -16,16 +16,12 @@ let find_string_value k = function
     | Some (_, `String value) -> Ok value
     | _ -> Rresult.R.error_msgf "couldn't find %s in json dictionary" k
 
-
 let find_devices x =
   let open Rresult in
   let device dev =
     find_string_value "name" dev >>= fun name ->
-    find_string_value "type" dev >>= fun typ ->
-    match typ with
-    | "BLOCK_BASIC" -> Ok (`Block name)
-    | "NET_BASIC" -> Ok (`Net name)
-    | _ -> Rresult.R.error_msgf "unknown device type %s in json" typ
+    find_string_value "type" dev >>| fun typ ->
+    name, typ
   in
   match x with
   | `Null | `Bool _ | `Float _ | `String _ | `A _ ->
@@ -36,9 +32,11 @@ let find_devices x =
       List.fold_left
         (fun acc dev ->
            acc >>= fun (block_devices, networks) ->
-           device dev >>= function
-           | `Block block -> Ok (block :: block_devices, networks)
-           | `Net net -> Ok (block_devices, (net, None) :: networks))
+           device dev >>= fun (name, typ) ->
+           match typ with
+           | "BLOCK_BASIC" -> Ok (name :: block_devices, networks)
+           | "NET_BASIC" -> Ok (block_devices, name :: networks)
+           | _ -> Rresult.R.error_msgf "unknown device type %s in json" typ)
         (Ok ([], [])) devices
     | _ -> Rresult.R.error_msg "devices field is not array in json"
 

src/vmm_unix.ml

@@ -209,14 +209,23 @@ let solo5_image_devices image =
     (Vmm_json.json_of_string s) >>= fun data ->
   Vmm_json.find_devices data
 
-let equal_blocks b1 b2 =
+let equal_string_lists b1 b2 err =
   let open Astring in
-  String.Set.(equal (of_list b1) (of_list b2))
+  if String.Set.(equal (of_list b1) (of_list b2)) then
+    Ok ()
+  else
+    R.error_msg err
 
-let equal_networks n1 n2 =
-  let open Astring in
-  let n1 = List.map fst n1 and n2 = List.map fst n2 in
-  String.Set.(equal (of_list n1) (of_list n2))
+let devices_match ~bridges ~block_devices (manifest_block, manifest_net) =
+  equal_string_lists manifest_block block_devices
+    "specified block device(s) does not match with manifest" >>= fun () ->
+  equal_string_lists manifest_net bridges
+    "specified bridge(s) does not match with the manifest"
+
+let manifest_devices_match ~bridges ~block_devices image_file =
+  solo5_image_devices image_file >>=
+  let bridges = List.map fst bridges in
+  devices_match ~bridges ~block_devices
 
 let prepare name vm =
   (match vm.Unikernel.typ with
@@ -231,11 +240,7 @@ let prepare name vm =
   Bos.OS.File.write filename (Cstruct.to_string image) >>= fun () ->
   solo5_image_target filename >>= fun target ->
   check_solo5_cmd (solo5_tender target) >>= fun _ ->
-  solo5_image_devices filename >>= fun (block_devices, networks) ->
-  (if equal_blocks vm.Unikernel.block_devices block_devices then Ok ()
-   else R.error_msg "specified block device(s) does not match with manifest") >>= fun () ->
-  (if equal_networks vm.Unikernel.bridges networks then Ok ()
-   else R.error_msg "specified bridge(s) does not match with the manifest") >>= fun () ->
+  manifest_devices_match ~bridges:vm.Unikernel.bridges ~block_devices:vm.Unikernel.block_devices filename >>= fun () ->
   let fifo = Name.fifo_file name in
   begin match fifo_exists fifo with
     | Ok true -> Ok ()

src/vmm_unix.mli

@@ -38,5 +38,5 @@ val restore : ?name:string -> unit -> (Cstruct.t, [> R.msg | `NoFile ]) result
 
 val vm_device : Unikernel.t -> (string, [> R.msg ]) result
 
-(* XXX: remove? *)
-val solo5_image_devices : Fpath.t -> (string list * (string * string option) list , [> R.msg]) result
+val manifest_devices_match : bridges:(string * string option) list ->
+  block_devices:string list -> Fpath.t -> (unit, [> R.msg]) result