put Policy in a submodule

app/vmm_cli.ml

@@ -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

app/vmmd_tls.ml

@@ -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

src/vmm_asn.ml

@@ -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,
+    (IS.elements policy.Policy.cpuids,
-     snd @@ List.split @@ String.Map.bindings policy.bridges)
+     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

src/vmm_commands.ml

@@ -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
 

src/vmm_commands.mli

@@ -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
 ]

src/vmm_core.ml

@@ -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 = [
+  type bridge = [
-  | `Internal of string
+    | `Internal of string
-  | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
+    | `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
+  let equal_bridge b1 b2 = match b1, b2 with
-  | `Internal a, `Internal a' -> String.equal a a'
+    | `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),
-    `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
+      let eq_ip a b = Ipaddr.V4.compare a b = 0 in
-    String.equal name name' &&
+      String.equal name name' &&
-    eq_ip ip_start ip_start' &&
+      eq_ip ip_start ip_start' &&
-    eq_ip ip_end ip_end' &&
+      eq_ip ip_end ip_end' &&
-    eq_ip ip_gw ip_gw' &&
+      eq_ip ip_gw ip_gw' &&
-    eq_int netmask netmask'
+      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
     | _ -> 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 =
+  let pp_bridge ppf = function
-  Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a"
+    | `Internal name -> Fmt.pf ppf "%s (internal)" name
-    res.vms pp_is res.cpuids res.memory
+    | `External (name, l, h, gw, nm) ->
-    Fmt.(option ~none:(unit "no") int) res.block
+      Fmt.pf ppf "%s: %a - %a, GW: %a/%d"
-    Fmt.(list ~sep:(unit ", ") pp_bridge)
+        name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm
-    (List.map snd (String.Map.bindings res.bridges))
 
-let sub_bridges super sub =
+  type t = {
-  String.Map.for_all (fun idx v ->
+    vms : int ;
-      match String.Map.find idx super, v with
+    cpuids : IS.t ;
-      | None, _ -> false
+    memory : int ;
-      | Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0
+    block : int option ;
-      | Some (`External (nam, supf, supl, gw, nm)),
+    bridges : bridge String.Map.t ;
-        `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 =
+  let equal p1 p2 =
-  match super, sub with
+    let eq_opt a b = match a, b with
-   | None, None -> true
+      | None, None -> true
-   | Some _, None -> true
+      | Some a, Some b -> eq_int a b
-   | Some x, Some y -> x >= y
+      | _ -> false
-   | None, Some _ -> 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 =
+  let sub_bridges super sub =
-  sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids &&
+    String.Map.for_all (fun idx v ->
-  sub.memory <= super.memory &&
+        match String.Map.find idx super, v with
-  sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
+        | 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)  =
+let vm_matches_res (res : Policy.t) (vm : vm_config)  =
-  res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
+  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")

src/vmm_core.mli

@@ -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 =
+module Policy : sig
-  [ `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
+    | `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 = {
+  type t = {
-  vms : int;
+    vms : int;
-  cpuids : IS.t;
+    cpuids : IS.t;
-  memory : int;
+    memory : int;
-  block : int option;
+    block : int option;
-  bridges : bridge Astring.String.Map.t;
+    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 is_sub : super:t -> sub:t -> bool
-
+end
-val sub_block : 'a option -> 'a option -> bool
-val sub_cpu : IS.t -> IS.t -> bool
-val is_sub : super:policy -> sub:policy -> bool
 
 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;

src/vmm_resources.ml

@@ -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) =
+let check_resource (p : Policy.t) (vm : vm_config) (res : res_entry) =
-  succ res.running_vms <= policy.vms &&
+  succ res.running_vms <= p.Policy.vms &&
-  res.used_memory + vm.requested_memory <= policy.memory &&
+  res.used_memory + vm.requested_memory <= p.Policy.memory &&
-  vm_matches_res policy vm
+  vm_matches_res p vm
 
-let check_resource_policy (policy : policy) (res : res_entry) =
+let check_resource_policy (p : Policy.t) (res : res_entry) =
-  res.running_vms <= policy.vms && res.used_memory <= policy.memory &&
+  res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory &&
-  match policy.block with
+  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
+        match entry, res with
-        | Some p, Policy p' -> if is_sub ~super:p ~sub:p then Some p' else None
+        | Policy p', Some p ->
-        | Some p, Vm vm ->
+          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 =

src/vmm_resources.mli

@@ -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]. *)

src/vmm_tls.mli

@@ -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

src/vmm_vmmd.ml

@@ -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)