command-line/albatross_cli.ml

@@ -102,9 +102,7 @@ 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
-  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 () ->
+  Bos.OS.File.read (Fpath.v image) >>| fun image ->
   let image, compressed = match compression with
     | 0 -> Cstruct.of_string image, false
     | level ->

src/vmm_json.ml

@@ -16,12 +16,16 @@ 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 ->
-    name, typ
+    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
   in
   match x with
   | `Null | `Bool _ | `Float _ | `String _ | `A _ ->
@@ -32,11 +36,9 @@ let find_devices x =
       List.fold_left
         (fun acc dev ->
            acc >>= fun (block_devices, 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)
+           device dev >>= function
+           | `Block block -> Ok (block :: block_devices, networks)
+           | `Net net -> Ok (block_devices, (net, None) :: networks))
         (Ok ([], [])) devices
     | _ -> Rresult.R.error_msg "devices field is not array in json"
 

src/vmm_unix.ml

@@ -209,39 +209,14 @@ let solo5_image_devices image =
     (Vmm_json.json_of_string s) >>= fun data ->
   Vmm_json.find_devices data
 
-let equal_string_lists b1 b2 err =
+let equal_blocks b1 b2 =
   let open Astring in
-  if String.Set.(equal (of_list b1) (of_list b2)) then
-    Ok ()
-  else
-    R.error_msg err
+  String.Set.(equal (of_list b1) (of_list b2))
 
-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 bridge_name (service, b) = match b with None -> service | Some b -> b
-
-let bridge_exists bridge_name =
-  let cmd =
-    match Lazy.force uname with
-    | FreeBSD -> Bos.Cmd.(v "ifconfig" % bridge_name)
-    | Linux -> Bos.Cmd.(v "ip" % "link" % "show" % bridge_name)
-  in
-  Bos.OS.Cmd.(run_out ~err:err_null cmd |> out_null |> success)
-  |> R.reword_error (fun _e -> R.msgf "interface %s does not exist" bridge_name)
-
-let bridges_exist bridges =
-  List.fold_left
-    (fun acc b -> acc >>= fun () -> bridge_exists (bridge_name b))
-    (Ok ()) bridges
+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 prepare name vm =
   (match vm.Unikernel.typ with
@@ -256,8 +231,11 @@ 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 _ ->
-  manifest_devices_match ~bridges:vm.Unikernel.bridges ~block_devices:vm.Unikernel.block_devices filename >>= fun () ->
-  bridges_exist vm.Unikernel.bridges >>= 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 () ->
   let fifo = Name.fifo_file name in
   begin match fifo_exists fifo with
     | Ok true -> Ok ()
@@ -274,11 +252,11 @@ let prepare name vm =
         let _ = Unix.umask old_umask in
         R.error_msgf "file %a error in %s: %a" Fpath.pp fifo f pp_unix_err e
   end >>= fun () ->
-  List.fold_left (fun acc arg ->
+  List.fold_left (fun acc (net, bri) ->
       acc >>= fun acc ->
-      let bridge = bridge_name arg in
+      let bridge = match bri with None -> net | Some b -> b in
       create_tap bridge >>= fun tap ->
-      Ok ((fst arg, tap) :: acc))
+      Ok ((net, tap) :: acc))
     (Ok []) vm.Unikernel.bridges >>= fun taps ->
   Ok (List.rev taps)
 

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
 
-val manifest_devices_match : bridges:(string * string option) list ->
-  block_devices:string list -> Fpath.t -> (unit, [> R.msg]) result
+(* XXX: remove? *)
+val solo5_image_devices : Fpath.t -> (string list * (string * string option) list , [> R.msg]) result