From 5cad5b00ea799525c066226b2320151022c8079c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Thu, 26 Nov 2020 14:43:06 +0100
Subject: [PATCH 1/5] Verify devices with manifest

---
 src/vmm_json.ml  | 26 ++++++++++++++++++++++++++
 src/vmm_unix.ml  | 22 ++++++++++++++++++++++
 src/vmm_unix.mli |  3 +++
 3 files changed, 51 insertions(+)

diff --git a/src/vmm_json.ml b/src/vmm_json.ml
index f320867..ff3be83 100644
--- a/src/vmm_json.ml
+++ b/src/vmm_json.ml
@@ -16,6 +16,32 @@ 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
+  in
+  match x with
+  | `Null | `Bool _ | `Float _ | `String _ | `A _ ->
+    Rresult.R.error_msg "couldn't find devices in json"
+  | `O dict ->
+    match List.find_opt (fun (key, _) -> String.equal key "devices") dict with
+    | Some (_, `A devices) ->
+      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))
+        (Ok ([], [])) devices
+    | _ -> Rresult.R.error_msg "devices field is not array in json"
+
 let json_of_string src =
   let dec d = match Jsonm.decode d with
     | `Lexeme l -> l
diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 50cedb3..1e39cdf 100644
--- a/src/vmm_unix.ml
+++ b/src/vmm_unix.ml
@@ -201,6 +201,23 @@ let solo5_image_target image =
 
 let solo5_tender = function Spt -> "solo5-spt" | Hvt -> "solo5-hvt"
 
+let solo5_image_devices image =
+  check_solo5_cmd "solo5-elftool" >>= fun cmd ->
+  let cmd = Bos.Cmd.(cmd % "query-manifest" % p image) in
+  Bos.OS.Cmd.(run_out cmd |> out_string |> success) >>= fun s ->
+  R.error_to_msg ~pp_error:Jsonm.pp_error
+    (Vmm_json.json_of_string s) >>= fun data ->
+  Vmm_json.find_devices data
+
+let equal_blocks b1 b2 =
+  let open Astring in
+  String.Set.(equal (of_list b1) (of_list b2))
+
+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
    | `Solo5 ->
@@ -214,6 +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 _ ->
+  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 ()
diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli
index 42fe555..4b78569 100644
--- a/src/vmm_unix.mli
+++ b/src/vmm_unix.mli
@@ -37,3 +37,6 @@ val dump : ?name:string -> Cstruct.t -> (unit, [> R.msg ]) result
 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

From 466e2d52b827754cd4f74ed3450a6fe391cbf12d Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Fri, 27 Nov 2020 22:24:52 +0100
Subject: [PATCH 2/5] check manifest with provided device arguments

---
 command-line/albatross_cli.ml |  4 +++-
 src/vmm_json.ml               | 16 +++++++---------
 src/vmm_unix.ml               | 27 ++++++++++++++++-----------
 src/vmm_unix.mli              |  4 ++--
 4 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/command-line/albatross_cli.ml b/command-line/albatross_cli.ml
index 4427ec6..aaf5904 100644
--- a/command-line/albatross_cli.ml
+++ b/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 ->
diff --git a/src/vmm_json.ml b/src/vmm_json.ml
index ff3be83..c622ffb 100644
--- a/src/vmm_json.ml
+++ b/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"
 
diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 1e39cdf..3823ade 100644
--- a/src/vmm_unix.ml
+++ b/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 ()
diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli
index 4b78569..d4e9471 100644
--- a/src/vmm_unix.mli
+++ b/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

From bc71e2675603b179cdb90f5d518d871c9f7e8986 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Fri, 27 Nov 2020 22:40:15 +0100
Subject: [PATCH 3/5] check that bridges with the provided names exist before
 creating tap devices

---
 src/vmm_unix.ml | 22 +++++++++++++++++++---
 1 file changed, 19 insertions(+), 3 deletions(-)

diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 3823ade..3033b1f 100644
--- a/src/vmm_unix.ml
+++ b/src/vmm_unix.ml
@@ -227,6 +227,21 @@ let manifest_devices_match ~bridges ~block_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" % "tuntap" % "show" % bridge_name)
+  in
+  Bos.OS.Cmd.(run_out ~err:err_null cmd |> out_null |> success)
+
+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
    | `Solo5 ->
@@ -241,6 +256,7 @@ let prepare name vm =
   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 () ->
   let fifo = Name.fifo_file name in
   begin match fifo_exists fifo with
     | Ok true -> Ok ()
@@ -257,11 +273,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)
 

From b4a4a28634edfefe5c7c2728662d5fdca3462c7d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Mon, 30 Nov 2020 11:37:34 +0100
Subject: [PATCH 4/5] Use ip link show to detect bridge

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.
---
 src/vmm_unix.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 3033b1f..38347ed 100644
--- a/src/vmm_unix.ml
+++ b/src/vmm_unix.ml
@@ -233,7 +233,7 @@ let bridge_exists bridge_name =
   let cmd =
     match Lazy.force uname with
     | FreeBSD -> Bos.Cmd.(v "ifconfig" % bridge_name)
-    | Linux -> Bos.Cmd.(v "ip" % "tuntap" % "show" % bridge_name)
+    | Linux -> Bos.Cmd.(v "ip" % "link" % "show" % bridge_name)
   in
   Bos.OS.Cmd.(run_out ~err:err_null cmd |> out_null |> success)
 

From 353284bd497f66fc63258d583e1f9f2ffb729bcd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Mon, 30 Nov 2020 11:54:42 +0100
Subject: [PATCH 5/5] Reword bridge detection error message

---
 src/vmm_unix.ml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml
index 38347ed..bf95132 100644
--- a/src/vmm_unix.ml
+++ b/src/vmm_unix.ml
@@ -236,6 +236,7 @@ let bridge_exists 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