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