Reword bridge detection error message

ip tuntap show lists all tuntap devices and ignores the rest of the
arguments, annoyingly. It will always return with exit code 0.

We do not detect if the interface is a bridge.

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 ->
+    find_string_value "type" dev >>| fun typ ->
-    match typ with
+    name, typ
-    | "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 _ ->
@@ -36,9 +32,11 @@ let find_devices x =
       List.fold_left
         (fun acc dev ->
            acc >>= fun (block_devices, networks) ->
-           device dev >>= function
+           device dev >>= fun (name, typ) ->
-           | `Block block -> Ok (block :: block_devices, networks)
+           match typ with
-           | `Net net -> Ok (block_devices, (net, None) :: networks))
+           | "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,39 @@ 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 devices_match ~bridges ~block_devices (manifest_block, manifest_net) =
-  let open Astring in
+  equal_string_lists manifest_block block_devices
-  let n1 = List.map fst n1 and n2 = List.map fst n2 in
+    "specified block device(s) does not match with manifest" >>= fun () ->
-  String.Set.(equal (of_list n1) (of_list n2))
+  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 prepare name vm =
   (match vm.Unikernel.typ with
@@ -231,11 +256,8 @@ 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) ->
+  manifest_devices_match ~bridges:vm.Unikernel.bridges ~block_devices:vm.Unikernel.block_devices filename >>= fun () ->
-  (if equal_blocks vm.Unikernel.block_devices block_devices then Ok ()
+  bridges_exist vm.Unikernel.bridges >>= fun () ->
-   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 ()
@@ -252,11 +274,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 (net, bri) ->
+  List.fold_left (fun acc arg ->
       acc >>= fun acc ->
-      let bridge = match bri with None -> net | Some b -> b in
+      let bridge = bridge_name arg in
       create_tap bridge >>= fun tap ->
-      Ok ((net, tap) :: acc))
+      Ok ((fst arg, 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
 
-(* XXX: remove? *)
+val manifest_devices_match : bridges:(string * string option) list ->
-val solo5_image_devices : Fpath.t -> (string list * (string * string option) list , [> R.msg]) result
+  block_devices:string list -> Fpath.t -> (unit, [> R.msg]) result