reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

delegation -> policy

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-12 20:34:00 +02:00
parent f8d8cffa46
commit ea83013068
6 changed files with 19 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
provision/vmm_sign.ml
View file

@ -31,12 +31,12 @@ let sign dbname cacert key csr days =
(X509.distinguished_name_to_string ri.X509.CA.subject)) ; (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
let issuer = X509.subject cacert in let issuer = X509.subject cacert in
(* TODO: handle version mismatch of the delegation cert specially here *) (* 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 | Ok d -> Some d
| Error _ -> None | Error _ -> None
in in
Logs.app (fun m -> m "using delegation %s: %a" (X509.distinguished_name_to_string issuer) 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 = let req_exts =
match match
List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions 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) -> 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)) ; 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 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 | None -> None
| Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids) | Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids)
in in
@ -91,7 +91,7 @@ let sign dbname cacert key csr days =
else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid -> else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid ->
Logs.app (fun m -> m "using CPU %d" 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 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 | None -> None
| Some x -> Some x.Vmm_core.memory | Some x -> Some x.Vmm_core.memory
in in
@ -119,7 +119,7 @@ let sign dbname cacert key csr days =
| None -> Ok None | None -> Ok None
| Some [] -> Ok None | Some [] -> Ok None
| Some x -> | Some x ->
match delegation with match policy with
| None -> Ok (Some x) | None -> Ok (Some x)
| Some del -> | Some del ->
let bridges = del.Vmm_core.bridges in 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 (opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function
| None -> Ok None | None -> Ok None
| Some x -> | Some x ->
match delegation with match policy with
| None -> Ok (Some x) | None -> Ok (Some x)
| Some d -> match d.Vmm_core.block with | Some d -> match d.Vmm_core.block with
| None -> Error (`Msg "trying to use a block device, when no block storage is delegated") | 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) Ok (exts @ l_exts)
| `Delegation -> | `Delegation ->
(req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x -> (req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x ->
match delegation with match policy with
| None -> Ok x | None -> Ok x
| Some d when Vmm_core.IS.subset d.Vmm_core.cpuids (Vmm_core.IS.of_list x) -> 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 | 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) ; 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 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 -> (req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= fun x ->
match delegation with match policy with
| None -> Ok x | None -> Ok x
| Some d when d.Vmm_core.memory >= x -> Ok x | Some d when d.Vmm_core.memory >= x -> Ok x
| Some d -> Rresult.R.error_msgf | 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 (opt Vmm_asn.Oid.block req_exts Vmm_asn.int_of_cstruct >>= function
| None -> Ok None | None -> Ok None
| Some x when x = 0 -> Ok None | Some x when x = 0 -> Ok None
| Some x -> match delegation with | Some x -> match policy with
| None -> Ok (Some x) | None -> Ok (Some x)
| Some d -> match d.Vmm_core.block with | Some d -> match d.Vmm_core.block with
| None -> Error (`Msg "cannot delegate block storage, don't have any delegated") | 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 | Some x -> (Vmm_asn.Oid.block, Vmm_asn.int_to_cstruct x) :: s_exts
in in
(req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x -> (req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x ->
match delegation with match policy with
| None -> Ok x | None -> Ok x
| Some d when d.Vmm_core.vms >= x -> Ok x | Some d when d.Vmm_core.vms >= x -> Ok x
| Some d -> Rresult.R.error_msgf | 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 (opt Vmm_asn.Oid.bridges req_exts Vmm_asn.bridges_of_cstruct >>= function
| None -> Ok None | None -> Ok None
| Some xs when xs = [] -> Ok None | Some xs when xs = [] -> Ok None
| Some xs -> match delegation with | Some xs -> match policy with
| None -> Ok (Some xs) | None -> Ok (Some xs)
| Some x -> | Some x ->
let sub = let sub =

2
src/vmm_asn.ml
View file

@ -170,7 +170,7 @@ let version_of_cert version cert =
R.error_msgf "unsupported asn version %a (expected %a)" R.error_msgf "unsupported asn version %a (expected %a)"
pp_version version' pp_version version pp_version version' pp_version version
let delegation_of_cert version cert = let policy_of_cert version cert =
version_of_cert version cert >>= fun () -> version_of_cert version cert >>= fun () ->
req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids -> req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids ->
req "memory" cert Oid.memory int_of_cstruct >>= fun memory -> req "memory" cert Oid.memory int_of_cstruct >>= fun memory ->

2
src/vmm_asn.mli
View file

@ -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 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. *) (** [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. *) (** [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 val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result

8
src/vmm_core.ml
View file

@ -111,7 +111,7 @@ let pp_bridge ppf = function
Fmt.pf ppf "%s: %a - %a, GW: %a/%d" 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 name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm
type delegation = { type policy = {
vms : int ; vms : int ;
cpuids : IS.t ; cpuids : IS.t ;
memory : int ; memory : int ;
@ -119,8 +119,8 @@ type delegation = {
bridges : bridge String.Map.t ; bridges : bridge String.Map.t ;
} }
let pp_delegation ppf res = let pp_policy ppf res =
Fmt.pf ppf "delegated: %d vms %a cpus %d MB memory %a MB block bridges: %a" Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a"
res.vms pp_is res.cpuids res.memory res.vms pp_is res.cpuids res.memory
Fmt.(option ~none:(unit "no") int) res.block Fmt.(option ~none:(unit "no") int) res.block
Fmt.(list ~sep:(unit ", ") pp_bridge) 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? *) (* TODO: uniqueness of n -- it should be an ordered set? *)
List.for_all (fun n -> String.Map.mem n nets) idxs 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 && res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
vm.requested_memory <= res.memory && vm.requested_memory <= res.memory &&
good_bridge vm.network res.bridges good_bridge vm.network res.bridges

2
src/vmm_resources.ml
View file

@ -15,7 +15,7 @@ let pp_res_entry ppf res =
let empty_res = { running_vms = 0 ; used_memory = 0 } 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 succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory
let add (vm : vm) (res : res_entry) = let add (vm : vm) (res : res_entry) =

2
src/vmm_resources.mli
View file

@ -29,7 +29,7 @@ val pp_entry : entry Fmt.t
(** [check_dynamic t vm delegates] checks whether creating [vm] would violate (** [check_dynamic t vm delegates] checks whether creating [vm] would violate
the policies of the [delegates] with respect to the running vms. *) the policies of the [delegates] with respect to the running vms. *)
val check_dynamic : t -> 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 (unit, [> `Msg of string ]) result
(** [exists t id] is [true] if the [id] already exists, [false] otherwise. *) (** [exists t id] is [true] if the [id] already exists, [false] otherwise. *)