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

put Policy in a submodule

This commit is contained in:
Hannes Mehnert 2018-11-11 03:09:37 +01:00
parent 89a1d30154
commit 561ba5c5df
11 changed files with 134 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
app/vmm_cli.ml
View File

@ -39,8 +39,7 @@ let policy vms memory cpus block bridges =
List.fold_left add String.Map.empty bridges
and cpuids = IS.of_list cpus
in
{ vms ; cpuids ; memory ; block ; bridges }
Policy.{ vms ; cpuids ; memory ; block ; bridges }
open Cmdliner
@ -83,7 +82,7 @@ let bridge =
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either specify 'name' or 'name/firstIP/lastIP/gatewayIP/netmask')"
in
(parse, pp_bridge)
(parse, Policy.pp_bridge)
let vm_c =
let parse s = match Name.of_string s with

2
app/vmmd_tls.ml
View File

@ -71,7 +71,7 @@ let handle ca (tls, addr) =
match r with
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
| Ok () ->
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.pp_policy policy) ;
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ;
let header = Vmm_commands.{version = my_version ; sequence = !command ; name = id } in
command := Int64.succ !command ;
Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function

9
src/vmm_asn.ml
View File

@ -58,10 +58,13 @@ let policy =
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpuids
in
{ vms ; cpuids ; memory ; block ; bridges }
Policy.{ vms ; cpuids ; memory ; block ; bridges }
and g policy =
(IS.elements policy.cpuids, policy.vms, policy.memory, policy.block,
snd @@ List.split @@ String.Map.bindings policy.bridges)
(IS.elements policy.Policy.cpuids,
policy.Policy.vms,
policy.Policy.memory,
policy.Policy.block,
snd @@ List.split @@ String.Map.bindings policy.Policy.bridges)
in
Asn.S.map f g @@
Asn.S.(sequence5

8
src/vmm_commands.ml
View File

@ -61,13 +61,13 @@ let pp_vm_cmd ppf = function
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_add of Policy.t
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy
| `Policy_add policy -> Fmt.pf ppf "policy add %a" Policy.pp policy
| `Policy_remove -> Fmt.string ppf "policy remove"
type block_cmd = [
@ -119,7 +119,7 @@ type header = {
type success = [
| `Empty
| `String of string
| `Policies of (Name.t * policy) list
| `Policies of (Name.t * Policy.t) list
| `Vms of (Name.t * vm_config) list
| `Blocks of (Name.t * int * bool) list
]
@ -130,7 +130,7 @@ let pp_block ppf (id, size, active) =
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_policy)) ppf ps
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Policy.pp)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_vm_config)) ppf vms
| `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks

4
src/vmm_commands.mli
View File

@ -35,7 +35,7 @@ type vm_cmd = [
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_add of Policy.t
| `Policy_remove
]
@ -73,7 +73,7 @@ type header = {
type success = [
| `Empty
| `String of string
| `Policies of (Name.t * policy) list
| `Policies of (Name.t * Policy.t) list
| `Vms of (Name.t * vm_config) list
| `Blocks of (Name.t * int * bool) list
]

151
src/vmm_core.ml
View File

@ -22,7 +22,6 @@ let pp_socket ppf t =
let name = socket_path t in
Fmt.pf ppf "socket: %s" name
module I = struct
type t = int
let compare : int -> int -> int = compare
@ -119,86 +118,88 @@ module Name = struct
Fmt.(pf ppf "[name %a]" (list ~sep:(unit ".") string) ids)
end
let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
module Policy = struct
let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
type bridge = [
| `Internal of string
| `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
]
type bridge = [
| `Internal of string
| `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
]
let eq_int (a : int) (b : int) = a = b
let eq_int (a : int) (b : int) = a = b
let eq_bridge b1 b2 = match b1, b2 with
| `Internal a, `Internal a' -> String.equal a a'
| `External (name, ip_start, ip_end, ip_gw, netmask),
`External (name', ip_start', ip_end', ip_gw', netmask') ->
let eq_ip a b = Ipaddr.V4.compare a b = 0 in
String.equal name name' &&
eq_ip ip_start ip_start' &&
eq_ip ip_end ip_end' &&
eq_ip ip_gw ip_gw' &&
eq_int netmask netmask'
| _ -> false
let pp_bridge ppf = function
| `Internal name -> Fmt.pf ppf "%s (internal)" name
| `External (name, l, h, gw, nm) ->
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 policy = {
vms : int ;
cpuids : IS.t ;
memory : int ;
block : int option ;
bridges : bridge String.Map.t ;
}
let eq_policy p1 p2 =
let eq_opt a b = match a, b with
| None, None -> true
| Some a, Some b -> eq_int a b
let equal_bridge b1 b2 = match b1, b2 with
| `Internal a, `Internal a' -> String.equal a a'
| `External (name, ip_start, ip_end, ip_gw, netmask),
`External (name', ip_start', ip_end', ip_gw', netmask') ->
let eq_ip a b = Ipaddr.V4.compare a b = 0 in
String.equal name name' &&
eq_ip ip_start ip_start' &&
eq_ip ip_end ip_end' &&
eq_ip ip_gw ip_gw' &&
eq_int netmask netmask'
| _ -> false
in
eq_int p1.vms p2.vms &&
IS.equal p1.cpuids p2.cpuids &&
eq_int p1.memory p2.memory &&
eq_opt p1.block p2.block &&
String.Map.equal eq_bridge p1.bridges p2.bridges
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)
(List.map snd (String.Map.bindings res.bridges))
let pp_bridge ppf = function
| `Internal name -> Fmt.pf ppf "%s (internal)" name
| `External (name, l, h, gw, nm) ->
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
let sub_bridges super sub =
String.Map.for_all (fun idx v ->
match String.Map.find idx super, v with
| None, _ -> false
| Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0
| Some (`External (nam, supf, supl, gw, nm)),
`External (nam', subf, subl, gw', nm') ->
String.compare nam nam' = 0 && nm = nm' &&
Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 &&
Ipaddr.V4.compare gw gw' = 0
| _ -> false)
sub
type t = {
vms : int ;
cpuids : IS.t ;
memory : int ;
block : int option ;
bridges : bridge String.Map.t ;
}
let sub_block super sub =
match super, sub with
| None, None -> true
| Some _, None -> true
| Some x, Some y -> x >= y
| None, Some _ -> false
let equal p1 p2 =
let eq_opt a b = match a, b with
| None, None -> true
| Some a, Some b -> eq_int a b
| _ -> false
in
eq_int p1.vms p2.vms &&
IS.equal p1.cpuids p2.cpuids &&
eq_int p1.memory p2.memory &&
eq_opt p1.block p2.block &&
String.Map.equal equal_bridge p1.bridges p2.bridges
let sub_cpu super sub = IS.subset sub super
let pp 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)
(List.map snd (String.Map.bindings res.bridges))
let is_sub ~super ~sub =
sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids &&
sub.memory <= super.memory &&
sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
let sub_bridges super sub =
String.Map.for_all (fun idx v ->
match String.Map.find idx super, v with
| None, _ -> false
| Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0
| Some (`External (nam, supf, supl, gw, nm)),
`External (nam', subf, subl, gw', nm') ->
String.compare nam nam' = 0 && nm = nm' &&
Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 &&
Ipaddr.V4.compare gw gw' = 0
| _ -> false)
sub
let sub_block super sub =
match super, sub with
| None, None -> true
| Some _, None -> true
| Some x, Some y -> x >= y
| None, Some _ -> false
let sub_cpu super sub = IS.subset sub super
let is_sub ~super ~sub =
sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids &&
sub.memory <= super.memory &&
sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
end
type vm_config = {
cpuid : int ;
@ -225,15 +226,15 @@ 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 : policy) (vm : vm_config) =
res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
let vm_matches_res (res : Policy.t) (vm : vm_config) =
res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids &&
vm.requested_memory <= res.memory &&
good_bridge vm.network res.bridges
let check_policies vm res =
let rec climb = function
| super :: sub :: xs ->
if is_sub ~super ~sub then climb (sub :: xs)
if Policy.is_sub ~super ~sub then climb (sub :: xs)
else Error (`Msg "policy violation")
| [x] -> Ok x
| [] -> Error (`Msg "empty resource list")

47
src/vmm_core.mli
View File

@ -5,15 +5,12 @@ type service = [ `Console | `Log | `Stats | `Vmmd ]
val socket_path : service -> string
val pp_socket : service Fmt.t
module I : sig type t = int val compare : int -> int -> int end
module IS : sig
include Set.S with type elt = I.t
include Set.S with type elt = int
end
val pp_is : IS.t Fmt.t
module IM : sig
include Map.S with type key = I.t
include Map.S with type key = int
end
module Name : sig
@ -41,31 +38,29 @@ module Name : sig
val block_name : t -> string -> t
end
type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
| `Internal of string ]
module Policy : sig
type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
| `Internal of string ]
val eq_bridge : bridge -> bridge -> bool
val equal_bridge : bridge -> bridge -> bool
val pp_bridge : bridge Fmt.t
val pp_bridge : bridge Fmt.t
type policy = {
vms : int;
cpuids : IS.t;
memory : int;
block : int option;
bridges : bridge Astring.String.Map.t;
}
type t = {
vms : int;
cpuids : IS.t;
memory : int;
block : int option;
bridges : bridge Astring.String.Map.t;
}
val eq_policy : policy -> policy -> bool
val equal : t -> t -> bool
val pp_policy : policy Fmt.t
val pp : t Fmt.t
val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool
val sub_block : 'a option -> 'a option -> bool
val sub_cpu : IS.t -> IS.t -> bool
val is_sub : super:policy -> sub:policy -> bool
val is_sub : super:t -> sub:t -> bool
end
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
@ -84,10 +79,10 @@ val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_vm_config : vm_config Fmt.t
val good_bridge : string list -> 'a Astring.String.map -> bool
val vm_matches_res : policy -> vm_config -> bool
val vm_matches_res : Policy.t -> vm_config -> bool
val check_policies :
vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result
vm_config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result
type vm = {
config : vm_config;

31
src/vmm_resources.ml
View File

@ -10,25 +10,25 @@ type res_entry = {
let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0 }
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 &&
vm_matches_res policy vm
let check_resource (p : Policy.t) (vm : vm_config) (res : res_entry) =
succ res.running_vms <= p.Policy.vms &&
res.used_memory + vm.requested_memory <= p.Policy.memory &&
vm_matches_res p vm
let check_resource_policy (policy : policy) (res : res_entry) =
res.running_vms <= policy.vms && res.used_memory <= policy.memory &&
match policy.block with
let check_resource_policy (p : Policy.t) (res : res_entry) =
res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory &&
match p.Policy.block with
| None -> res.used_blockspace = 0
| Some mb -> res.used_blockspace <= mb
type entry =
| Vm of vm
| Block of int * bool
| Policy of policy
| Policy of Policy.t
let pp_entry id ppf = function
| Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id pp_policy p
| Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id Policy.pp p
| Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used
type t = entry Vmm_trie.t
@ -117,7 +117,7 @@ let insert_vm t name vm =
let check_policy_above t name p =
let above = Vmm_trie.collect name t in
List.for_all (fun (id, node) -> match node with
| Policy p' -> is_sub ~super:p' ~sub:p
| Policy p' -> Policy.is_sub ~super:p' ~sub:p
| x ->
Logs.err (fun m -> m "expected policy, found %a"
(pp_entry id) x) ;
@ -129,14 +129,17 @@ let check_policy_below t name p =
if Name.is_root name then
res
else
match res, entry with
| Some p, Policy p' -> if is_sub ~super:p ~sub:p then Some p' else None
| Some p, Vm vm ->
match entry, res with
| Policy p', Some p ->
if Policy.is_sub ~super:p ~sub:p'
then Some p'
else None
| Vm vm, Some p ->
let cfg = vm.config in
if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
then Some p
else None
| res, _ -> res)
| _, res -> res)
(Some p)
let insert_policy t name p =

6
src/vmm_resources.mli
View File

@ -21,7 +21,7 @@ val empty : t
val find_vm : t -> Vmm_core.Name.t -> Vmm_core.vm option
(** [find_policy t Name.t] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.Name.t -> Vmm_core.policy option
val find_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t option
(** [find_block t Name.t] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.Name.t -> (int * bool) option
@ -36,7 +36,7 @@ val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.vm -> (t, [> `Msg of string]) r
(** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
the new [t] or an error. *)
val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.policy -> (t, [> `Msg of string]) result
val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t -> (t, [> `Msg of string]) result
(** [check_block_policy t Name.t size] checks whether [size] under [Name.t] in [t] would be
allowed under the current policies. *)
@ -58,7 +58,7 @@ val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
(** [fold t Name.t f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [Name.t] over [t]. *)
val fold : t -> Vmm_core.Name.t ->
(Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.Name.t -> Vmm_core.policy -> 'a -> 'a) ->
(Vmm_core.Name.t -> Vmm_core.Policy.t -> 'a -> 'a) ->
(Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a
(** [pp] is a pretty printer for [t]. *)

2
src/vmm_tls.mli
View File

@ -6,5 +6,5 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t ->
val handle :
'a -> Vmm_commands.version ->
X509.t list ->
(Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.policy) list * Vmm_commands.t,
(Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.t,
[> `Msg of string ]) Result.result

2
src/vmm_vmmd.ml
View File

@ -124,7 +124,7 @@ let handle_policy_cmd t reply id = function
Logs.debug (fun m -> m "insert policy %a" Name.pp id) ;
let same_policy = match Vmm_resources.find_policy t.resources id with
| None -> false
| Some p' -> eq_policy policy p'
| Some p' -> Policy.equal policy p'
in
if same_policy then
Ok (t, [ reply (`String "no modification of policy") ], `Loop)