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