diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index b425818..f7bb51a 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -31,12 +31,12 @@ let sign dbname cacert key csr days = (X509.distinguished_name_to_string ri.X509.CA.subject)) ; let issuer = X509.subject cacert in (* TODO: handle version mismatch of the delegation cert specially here *) - let delegation = match Vmm_asn.delegation_of_cert asn_version cacert with + let policy = match Vmm_asn.policy_of_cert asn_version cacert with | Ok d -> Some d | Error _ -> None in Logs.app (fun m -> m "using delegation %s: %a" (X509.distinguished_name_to_string issuer) - Fmt.(option ~none:(unit "no") Vmm_core.pp_delegation) delegation) ; + Fmt.(option ~none:(unit "no") Vmm_core.pp_policy) policy) ; let req_exts = match List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions @@ -66,7 +66,7 @@ let sign dbname cacert key csr days = req Vmm_asn.Oid.vmimage req_exts Vmm_asn.image_of_cstruct >>= fun (typ, img) -> Logs.app (fun m -> m "image of type %a, size %d" Vmm_core.pp_vmtype typ (Cstruct.len img)) ; let s_exts = (Vmm_asn.Oid.vmimage, Vmm_asn.image_to_cstruct (typ, img)) :: s_exts in - let cpuids = match delegation with + let cpuids = match policy with | None -> None | Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids) in @@ -91,7 +91,7 @@ let sign dbname cacert key csr days = else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid -> Logs.app (fun m -> m "using CPU %d" cpuid) ; let s_exts = (Vmm_asn.Oid.cpuid, Vmm_asn.int_to_cstruct cpuid) :: s_exts in - let memory = match delegation with + let memory = match policy with | None -> None | Some x -> Some x.Vmm_core.memory in @@ -119,7 +119,7 @@ let sign dbname cacert key csr days = | None -> Ok None | Some [] -> Ok None | Some x -> - match delegation with + match policy with | None -> Ok (Some x) | Some del -> let bridges = del.Vmm_core.bridges in @@ -141,7 +141,7 @@ let sign dbname cacert key csr days = (opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function | None -> Ok None | Some x -> - match delegation with + match policy with | None -> Ok (Some x) | Some d -> match d.Vmm_core.block with | None -> Error (`Msg "trying to use a block device, when no block storage is delegated") @@ -167,7 +167,7 @@ let sign dbname cacert key csr days = Ok (exts @ l_exts) | `Delegation -> (req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x -> - match delegation with + match policy with | None -> Ok x | Some d when Vmm_core.IS.subset d.Vmm_core.cpuids (Vmm_core.IS.of_list x) -> Ok x | Some d -> Rresult.R.error_msgf @@ -177,7 +177,7 @@ let sign dbname cacert key csr days = Logs.app (fun m -> m "delegating CPUs %a" Fmt.(list ~sep:(unit ",") int) cpuids) ; let s_exts = (Vmm_asn.Oid.cpuids, Vmm_asn.ints_to_cstruct cpuids) :: s_exts in (req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= fun x -> - match delegation with + match policy with | None -> Ok x | Some d when d.Vmm_core.memory >= x -> Ok x | Some d -> Rresult.R.error_msgf @@ -187,7 +187,7 @@ let sign dbname cacert key csr days = (opt Vmm_asn.Oid.block req_exts Vmm_asn.int_of_cstruct >>= function | None -> Ok None | Some x when x = 0 -> Ok None - | Some x -> match delegation with + | Some x -> match policy with | None -> Ok (Some x) | Some d -> match d.Vmm_core.block with | None -> Error (`Msg "cannot delegate block storage, don't have any delegated") @@ -200,7 +200,7 @@ let sign dbname cacert key csr days = | Some x -> (Vmm_asn.Oid.block, Vmm_asn.int_to_cstruct x) :: s_exts in (req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x -> - match delegation with + match policy with | None -> Ok x | Some d when d.Vmm_core.vms >= x -> Ok x | Some d -> Rresult.R.error_msgf @@ -210,7 +210,7 @@ let sign dbname cacert key csr days = (opt Vmm_asn.Oid.bridges req_exts Vmm_asn.bridges_of_cstruct >>= function | None -> Ok None | Some xs when xs = [] -> Ok None - | Some xs -> match delegation with + | Some xs -> match policy with | None -> Ok (Some xs) | Some x -> let sub = diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d054e41..d541d3b 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -170,7 +170,7 @@ let version_of_cert version cert = R.error_msgf "unsupported asn version %a (expected %a)" pp_version version' pp_version version -let delegation_of_cert version cert = +let policy_of_cert version cert = version_of_cert version cert >>= fun () -> req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids -> req "memory" cert Oid.memory int_of_cstruct >>= fun memory -> diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 15d42f9..7a571b5 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -154,7 +154,7 @@ val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result (** [delegation_of_cert version cert] is either the decoded delegation, or an error. *) -val delegation_of_cert : version -> X509.t -> (Vmm_core.delegation, [> `Msg of string ]) result +val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result (** [command_of_cert version cert] is either the decoded command, or an error. *) val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 6b088e6..9c470b2 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -111,7 +111,7 @@ let pp_bridge ppf = function Fmt.pf ppf "%s: %a - %a, GW: %a/%d" name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm -type delegation = { +type policy = { vms : int ; cpuids : IS.t ; memory : int ; @@ -119,8 +119,8 @@ type delegation = { bridges : bridge String.Map.t ; } -let pp_delegation ppf res = - Fmt.pf ppf "delegated: %d vms %a cpus %d MB memory %a MB block bridges: %a" +let pp_policy ppf res = + Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a" res.vms pp_is res.cpuids res.memory Fmt.(option ~none:(unit "no") int) res.block Fmt.(list ~sep:(unit ", ") pp_bridge) @@ -184,7 +184,7 @@ let good_bridge idxs nets = (* TODO: uniqueness of n -- it should be an ordered set? *) List.for_all (fun n -> String.Map.mem n nets) idxs -let vm_matches_res (res : delegation) (vm : vm_config) = +let vm_matches_res (res : policy) (vm : vm_config) = res.vms >= 1 && IS.mem vm.cpuid res.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 0a9e5ef..e5e84d7 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -15,7 +15,7 @@ let pp_res_entry ppf res = let empty_res = { running_vms = 0 ; used_memory = 0 } -let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) = +let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory let add (vm : vm) (res : res_entry) = diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 697b778..08a12ca 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -29,7 +29,7 @@ val pp_entry : entry Fmt.t (** [check_dynamic t vm delegates] checks whether creating [vm] would violate the policies of the [delegates] with respect to the running vms. *) val check_dynamic : t -> - Vmm_core.vm_config -> (string * Vmm_core.delegation) list -> + Vmm_core.vm_config -> (string * Vmm_core.policy) list -> (unit, [> `Msg of string ]) result (** [exists t id] is [true] if the [id] already exists, [false] otherwise. *)