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 ->
-    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,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 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 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) ->
-  (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 () ->
+  bridges_exist vm.Unikernel.bridges >>= 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 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