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 f320867..c622ffb 100644 --- a/src/vmm_json.ml +++ b/src/vmm_json.ml @@ -16,6 +16,30 @@ 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 + 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 >>= 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" + 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..bf95132 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -201,6 +201,48 @@ 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_string_lists b1 b2 err = + let open Astring in + if String.Set.(equal (of_list b1) (of_list b2)) then + Ok () + else + R.error_msg err + +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 | `Solo5 -> @@ -214,6 +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 _ -> + 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 () @@ -230,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) diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index 42fe555..d4e9471 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 + +val manifest_devices_match : bridges:(string * string option) list -> + block_devices:string list -> Fpath.t -> (unit, [> R.msg]) result