policies:

vmmc now has more subcommands
  - policy [-n name] returns all policies in name and below
  - add_policy [-n name] [--cpu cpuid] [--mem mem] [--bridge bridge] [--block size] adds a policy
  - remove [-n name] removes policy at name

policy is just the same which is in vmm_req_delegation, and vmm_resources now check them:
- you cannot insert a subpolicy violating the prefix
- you cannot insert a policy which would forbid current resource usage
- you cannot insert a policy with which any subpolicy would be invalid
- you can adjust (increase/decrease) a policy if the above invariants are kept

implement "force create" directly in vmmd: much nicer to
 - check resource constraints,
 - kill vm potentially,
 - and create a new vm,
all as single transaction.

app/vmmc.ml

@@ -2,6 +2,8 @@
 
 open Lwt.Infix
 
+open Astring
+
 open Vmm_core
 
 let my_version = `WV2
@@ -62,7 +64,65 @@ let info_ _ opt_socket name =
   ) ;
   `Ok ()
 
-let really_destroy opt_socket name =
+let policy _ opt_socket name =
+  Lwt_main.run (
+    connect (socket `Vmmd opt_socket) >>= fun fd ->
+    let policy = Vmm_wire.Vm.policy my_command my_version name in
+    (Vmm_lwt.write_wire fd policy >>= function
+      | Ok () ->
+        (process fd >|= function
+          | Error () -> ()
+          | Ok data ->
+            match Vmm_wire.Vm.decode_policies data with
+            | Ok (policies, _) ->
+              List.iter (fun (id, policy) ->
+                  Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
+                policies
+            | Error (`Msg msg) ->
+              Logs.err (fun m -> m "error %s while decoding policies" msg))
+      | Error `Exception -> Lwt.return_unit) >>= fun () ->
+    Vmm_lwt.safe_close fd
+  ) ;
+  `Ok ()
+
+let remove_policy _ opt_socket name =
+  Lwt_main.run (
+    connect (socket `Vmmd opt_socket) >>= fun fd ->
+    let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in
+    (Vmm_lwt.write_wire fd cmd >>= function
+      | Ok () ->
+        (process fd >|= function
+          | Error () -> ()
+          | Ok _ -> Logs.app (fun m -> m "removed policy"))
+      | Error `Exception -> Lwt.return_unit) >>= fun () ->
+    Vmm_lwt.safe_close fd) ;
+  `Ok ()
+
+let add_policy _ opt_socket name vms memory cpus block bridges =
+  Lwt_main.run (
+    connect (socket `Vmmd opt_socket) >>= fun fd ->
+    let bridges = match bridges with
+      | xs ->
+        let add m v =
+          let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+          String.Map.add n v m
+        in
+        List.fold_left add String.Map.empty xs
+    and cpuids = IS.of_list cpus
+    in
+    let policy = { vms ; cpuids ; memory ; block ; bridges } in
+    let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in
+    (Vmm_lwt.write_wire fd cmd >>= function
+      | Ok () ->
+        (process fd >|= function
+          | Error () -> ()
+          | Ok _ -> Logs.app (fun m -> m "added policy"))
+      | Error `Exception -> Lwt.return_unit) >>= fun () ->
+    Vmm_lwt.safe_close fd) ;
+  `Ok ()
+
+let destroy _ opt_socket name =
+  Lwt_main.run (
     connect (socket `Vmmd opt_socket) >>= fun fd ->
     let cmd = Vmm_wire.Vm.destroy my_command my_version name in
     (Vmm_lwt.write_wire fd cmd >>= function
@@ -71,10 +131,7 @@ let really_destroy opt_socket name =
           | Error () -> ()
           | Ok _ -> Logs.app (fun m -> m "destroyed VM"))
       | Error `Exception -> Lwt.return_unit) >>= fun () ->
-  Vmm_lwt.safe_close fd
+    Vmm_lwt.safe_close fd) ;
-
-let destroy _ opt_socket name =
-  Lwt_main.run (really_destroy opt_socket name) ;
   `Ok ()
 
 let create _ opt_socket force name image cpuid requested_memory boot_params block_device network =
@@ -93,19 +150,19 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
     vmimage ; argv
   } in
   Lwt_main.run (
-    (if force then
-       really_destroy opt_socket name
-     else
-       Lwt.return_unit) >>= fun () ->
     connect (socket `Vmmd opt_socket) >>= fun fd ->
-    let vm = Vmm_wire.Vm.create my_command my_version vm_config in
+    let vm =
+      if force then
+        Vmm_wire.Vm.force_create my_command my_version vm_config
+      else
+        Vmm_wire.Vm.create my_command my_version vm_config
+    in
     (Vmm_lwt.write_wire fd vm >>= function
       | Error `Exception -> Lwt.return_unit
       | Ok () -> process fd >|= function
         | Ok _ -> Logs.app (fun m -> m "successfully started VM")
         | Error () -> ()) >>= fun () ->
-    Vmm_lwt.safe_close fd
+    Vmm_lwt.safe_close fd ) ;
-  ) ;
   `Ok ()
 
 let console _ opt_socket name =
@@ -315,6 +372,15 @@ let opt_vmname =
   let doc = "Name virtual machine." in
   Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
 
+let remove_policy_cmd =
+  let doc = "removes a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Removes a policy."]
+  in
+  Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)),
+  Term.info "remove" ~doc ~man
+
 let info_cmd =
   let doc = "information about VMs" in
   let man =
@@ -324,14 +390,72 @@ let info_cmd =
   Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)),
   Term.info "info" ~doc ~man
 
+let policy_cmd =
+  let doc = "active policies" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about policies."]
+  in
+  Term.(ret (const policy $ setup_log $ socket $ opt_vmname)),
+  Term.info "policy" ~doc ~man
+
+let cpus =
+  let doc = "CPUids to allow" in
+  Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
+
+let vms =
+  let doc = "Number of VMs to allow" in
+  Arg.(required & pos 0 (some int) None & info [] ~doc)
+
+let block =
+  let doc = "Block storage to allow" in
+  Arg.(value & opt (some int) None & info [ "block" ] ~doc)
+
+let mem =
+  let doc = "Memory to allow" in
+  Arg.(value & opt int 512 & info [ "mem" ] ~doc)
+
+let b =
+  let parse s =
+    match String.cuts ~sep:"/" s with
+    | [ name ; fst ; lst ; gw ; nm ] ->
+      begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
+        | Some fst, Some lst, Some gw ->
+          (try
+             let nm = int_of_string nm in
+             if nm > 0 && nm <= 32 then
+               let net = Ipaddr.V4.Prefix.make nm gw in
+               if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
+                 `Ok (`External (name, fst, lst, gw, nm))
+               else
+                 `Error "first or last IP are not in subnet"
+             else
+               `Error "netmask must be > 0 and <= 32"
+           with Failure _ -> `Error "couldn't parse netmask")
+        | _ -> `Error "couldn't parse IP address"
+      end
+    | [ name ] -> `Ok (`Internal name)
+    | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
+  in
+  (parse, Vmm_core.pp_bridge)
+
+let bridge =
+  let doc = "Bridge to provision" in
+  Arg.(value & opt_all b [] & info [ "bridge" ] ~doc)
+
+let add_policy_cmd =
+  let doc = "Add a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Adds a policy."]
+  in
+  Term.(ret (const add_policy $ setup_log $ socket $ opt_vmname $ vms $ mem $ cpus $ block $ bridge)),
+  Term.info "add_policy" ~doc ~man
+
 let cpu =
   let doc = "CPUid" in
   Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
 
-let mem =
-  let doc = "Memory to provision" in
-  Arg.(value & opt int 512 & info [ "mem" ] ~doc)
-
 let args =
   let doc = "Boot arguments" in
   Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
@@ -402,7 +526,7 @@ let default_cmd =
   Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
   Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man
 
-let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
 
 let () =
   match Term.eval_choice default_cmd cmds

app/vmmd.ml

@@ -22,44 +22,9 @@ type out = [
   | `Log of Cstruct.t
 ]
 
-let handle state out c_fd fd addr =
+let state = ref (Vmm_engine.init ())
-  (* out is for `Log | `Stat | `Cons (including reconnect semantics) *)
+
-  (* need to handle data out (+ die on write failure) *)
+let create c_fd process cont =
-  Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
-  (* now we need to read a packet and handle it
-    (1)
-     (a) easy for info (look up name/prefix in resources)
-     (b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup)
-         logs "destroy issued"
-     (c) create initiates the vm startup procedure:
-         write image file, create fifo, create tap(s), send fifo to console
-         -- Lwt effects happen (console) --
-         executes solo5-hvt + waiter, send stats pid and taps, inserts await into state, logs "created vm"
-         -- Lwt effects happen (stats, logs, wait_and_clear) --
-    (2) goto (1)
-  *)
-  let process xs =
-    Lwt_list.iter_p (function
-        | #out as o -> out o
-        | `Data cs ->
-          (* rather: terminate connection *)
-          Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs
-  in
-  Logs.debug (fun m -> m "now reading") ;
-  (Vmm_lwt.read_wire fd >>= function
-    | Error _ ->
-      Logs.err (fun m -> m "error while reading") ;
-      Lwt.return_unit
-    | Ok (hdr, buf) ->
-      Logs.debug (fun m -> m "read sth") ;
-      let state', data, next = Vmm_engine.handle_command !state hdr buf in
-      state := state' ;
-      process data >>= fun () ->
-      match next with
-      | `End -> Lwt.return_unit
-      | `Wait (task, out) -> task >>= fun () -> process out
-      | `Create cont ->
-        (* data contained a write to console, we need to wait for its reply first *)
   Vmm_lwt.read_wire c_fd >>= function
   | Ok (hdr, data) ->
     if Vmm_wire.is_fail hdr then begin
@@ -101,7 +66,57 @@ let handle state out c_fd fd addr =
     Lwt.return_unit
   | Error _ ->
     Logs.err (fun m -> m "error while reading from console") ;
-          Lwt.return_unit ) >>= fun () ->
+    Lwt.return_unit
+
+let handle out c_fd fd addr =
+  (* out is for `Log | `Stat | `Cons (including reconnect semantics) *)
+  (* need to handle data out (+ die on write failure) *)
+  Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
+  (* now we need to read a packet and handle it
+    (1)
+     (a) easy for info (look up name/prefix in resources)
+     (b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup)
+         logs "destroy issued"
+     (c) create initiates the vm startup procedure:
+         write image file, create fifo, create tap(s), send fifo to console
+         -- Lwt effects happen (console) --
+         executes solo5-hvt + waiter, send stats pid and taps, inserts await into state, logs "created vm"
+         -- Lwt effects happen (stats, logs, wait_and_clear) --
+    (2) goto (1)
+  *)
+  let process xs =
+    Lwt_list.iter_p (function
+        | #out as o -> out o
+        | `Data cs ->
+          (* rather: terminate connection *)
+          Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs
+  in
+  Logs.debug (fun m -> m "now reading") ;
+  (Vmm_lwt.read_wire fd >>= function
+    | Error _ ->
+      Logs.err (fun m -> m "error while reading") ;
+      Lwt.return_unit
+    | Ok (hdr, buf) ->
+      Logs.debug (fun m -> m "read sth") ;
+      let state', data, next = Vmm_engine.handle_command !state hdr buf in
+      state := state' ;
+      process data >>= fun () ->
+      match next with
+      | `End -> Lwt.return_unit
+      | `Wait (task, out) -> task >>= fun () -> process out
+      | `Wait_and_create (state', task, next) ->
+        state := state' ;
+        task >>= fun () ->
+        let state', data, n = next !state in
+        state := state' ;
+        process data >>= fun () ->
+        (match n with
+         | `End -> Lwt.return_unit
+         | `Create cont -> create c_fd process cont)
+      | `Create cont ->
+        create c_fd process cont
+        (* data contained a write to console, we need to wait for its reply first *)
+  ) >>= fun () ->
   Vmm_lwt.safe_close fd
 
 let init_sock sock =
@@ -162,7 +177,6 @@ let jump _ =
      (create_mbox `Log >|= function
        | None -> invalid_arg "cannot connect to log socket"
        | Some l -> l) >>= fun (l, _l_fd) ->
-     let state = ref (Vmm_engine.init ()) in
      let out = function
        | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data)
        | `Log data -> Lwt_mvar.put l data
@@ -172,7 +186,7 @@ let jump _ =
      let rec loop () =
        Lwt_unix.accept ss >>= fun (fd, addr) ->
        Lwt_unix.set_close_on_exec fd ;
-       Lwt.async (fun () -> handle state out c_fd fd addr) ;
+       Lwt.async (fun () -> handle out c_fd fd addr) ;
        loop ()
      in
      loop ())

src/vmm_asn.ml

@@ -103,6 +103,38 @@ let strings_of_cstruct, strings_to_cstruct =
 
 let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string
 
+let policy_obj =
+  let f (cpuids, vms, memory, block, bridges) =
+    let bridges = match bridges with
+      | xs ->
+        let add m v =
+          let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+          String.Map.add n v m
+        in
+        List.fold_left add String.Map.empty xs
+    and cpuids = IS.of_list cpuids
+    in
+    { 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)
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence5
+           (required ~label:"cpuids" Asn.S.(sequence_of int))
+           (required ~label:"vms" int)
+           (required ~label:"memory" int)
+           (optional ~label:"block" int)
+           (required ~label:"bridges" Asn.S.(sequence_of bridge)))
+
+let policy_of_cstruct, policy_to_cstruct =
+  let c = Asn.codec Asn.der policy_obj in
+  ((fun cs -> match Asn.decode c cs with
+      | Ok x -> Ok x
+      | Error (`Parse msg) -> Error (`Msg msg)),
+   Asn.encode c)
+
+
 let image =
   let f = function
     | `C1 x -> `Hvt_amd64, x

src/vmm_asn.mli

@@ -139,6 +139,13 @@ val strings_to_cstruct : string list -> Cstruct.t
     encoded [buffer] or an error. *)
 val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result
 
+(** [policy_to_cstruct xs] is the DER encoded policy. *)
+val policy_to_cstruct : Vmm_core.policy -> Cstruct.t
+
+(** [policy_of_cstruct buffer] is either a decoded policy of the DER
+    encoded [buffer] or an error. *)
+val policy_of_cstruct : Cstruct.t -> (Vmm_core.policy * Cstruct.t, [> `Msg of string ]) result
+
 (** {1 Decoding functions} *)
 
 (** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *)
@@ -153,7 +160,7 @@ val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string
 (** [crl_of_cert id cert] is either the decoded revocation list, or an error. *)
 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. *)
+(** [policy_of_cert version cert] is either the decoded policy, or an error. *)
 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. *)

src/vmm_core.ml

@@ -7,13 +7,15 @@ open Rresult.R.Infix
 let tmpdir = Fpath.(v "/var" / "run" / "albatross")
 let dbdir = Fpath.(v "/var" / "db" / "albatross")
 
-let socket_path =
+let socket_path t =
-  let path name = Fpath.(to_string (tmpdir / "util" / name + "sock")) in
+  let path name = Fpath.(tmpdir / "util" / name + "sock") in
-  function
+  let path = match t with
     | `Console -> path "console"
-  | `Vmmd -> Fpath.(to_string (tmpdir / "vmmd.sock"))
+    | `Vmmd -> Fpath.(tmpdir / "vmmd" + "sock")
     | `Stats -> path "stat"
     | `Log -> path "log"
+  in
+  Fpath.to_string path
 
 let pp_socket ppf t =
   let name = socket_path t in
@@ -95,6 +97,10 @@ let drop_super ~super ~sub =
 let is_sub_id ~super ~sub =
   match drop_super ~super ~sub with None -> false | Some _ -> true
 
+let domain id = match List.rev id with
+  | _::prefix -> List.rev prefix
+  | [] -> []
+
 let pp_id ppf ids =
   Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids)
 
@@ -185,6 +191,7 @@ let good_bridge idxs nets =
   List.for_all (fun n -> String.Map.mem n nets) idxs
 
 let vm_matches_res (res : policy) (vm : vm_config)  =
+  (* TODO block device *)
   res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
   vm.requested_memory <= res.memory &&
   good_bridge vm.network res.bridges

src/vmm_engine.ml

@@ -39,13 +39,15 @@ let log state (hdr, event) =
   Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ;
   ({ state with log_counter }, `Log data)
 
-let handle_create t hdr vm_config (* policies *) =
+let handle_create t hdr vm_config =
-  (if Vmm_resources.exists t.resources vm_config.vname then
+  (match Vmm_resources.find_vm t.resources vm_config.vname with
-     Error (`Msg "VM with same name is already running")
+   | Some _ -> Error (`Msg "VM with same name is already running")
+   | None -> Ok ()) >>= fun () ->
+  Logs.debug (fun m -> m "now checking resource policies") ;
+  (if Vmm_resources.check_vm_policy t.resources vm_config then
+     Ok ()
    else
-     Ok ()) >>= fun () ->
+     Error (`Msg "resource policies don't allow this")) >>= fun () ->
-  (* Logs.debug (fun m -> m "now checking dynamic policies") ;
-     Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *)
   (* prepare VM: save VM image to disk, create fifo, ... *)
   Vmm_unix.prepare vm_config >>= fun taps ->
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
@@ -56,7 +58,7 @@ let handle_create t hdr vm_config (* policies *) =
           (* actually execute the vm *)
           Vmm_unix.exec vm_config taps >>= fun vm ->
           Logs.debug (fun m -> m "exec()ed vm") ;
-          Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources ->
+          Vmm_resources.insert_vm t.resources vm >>= fun resources ->
           let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in
           let used_bridges =
             List.fold_left2 (fun b br ta ->
@@ -81,13 +83,7 @@ let handle_shutdown t vm r =
   (match Vmm_unix.shutdown vm with
    | Ok () -> ()
    | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
-  let resources =
+  let resources = Vmm_resources.remove t.resources vm.config.vname in
-    match Vmm_resources.remove t.resources vm.config.vname vm with
-    | Ok resources -> resources
-    | Error (`Msg e) ->
-      Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ;
-      t.resources
-  in
   let used_bridges =
     List.fold_left2 (fun b br ta ->
         let old = match String.Map.find br b with
@@ -118,25 +114,79 @@ let handle_command t hdr buf =
       Ok (t, [], `End)
     end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
       Error (`Msg "unknown client version")
-    else Vmm_wire.decode_strings buf >>= fun (id, _off) ->
+    else Vmm_wire.decode_strings buf >>= fun (id, off) ->
       match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with
       | None -> Error (`Msg "unknown command")
+      | Some Vmm_wire.Vm.Remove_policy ->
+        Logs.debug (fun m -> m "remove policy %a" pp_id id) ;
+        let resources = Vmm_resources.remove t.resources id in
+        let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in
+        Ok ({ t with resources }, [ `Data success ], `End)
+      | Some Vmm_wire.Vm.Insert_policy ->
+        begin
+          Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
+          Vmm_asn.policy_of_cstruct (Cstruct.shift buf off) >>= fun (policy, _) ->
+          Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
+          let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in
+          Ok ({ t with resources }, [ `Data success ], `End)
+        end
+      | Some Vmm_wire.Vm.Policy ->
+        begin
+          Logs.debug (fun m -> m "policy %a" pp_id id) ;
+          let policies =
+            Vmm_resources.fold t.resources id
+              (fun _ policies -> policies)
+              (fun prefix policy policies-> (prefix, policy) :: policies)
+              []
+          in
+          match policies with
+          | [] ->
+            Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ;
+            Error (`Msg "policy: not found")
+          | _ ->
+            let out = Vmm_wire.Vm.policy_reply hdr.Vmm_wire.id t.client_version policies in
+            Ok (t, [ `Data out ], `End)
+        end
       | Some Vmm_wire.Vm.Info ->
+        begin
           Logs.debug (fun m -> m "info %a" pp_id id) ;
-        begin match Vmm_resources.find t.resources id with
+          let vms =
-          | None ->
+            Vmm_resources.fold t.resources id
+              (fun vm vms -> vm :: vms)
+              (fun _ _ vms-> vms)
+              []
+          in
+          match vms with
+          | [] ->
             Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
             Error (`Msg "info: not found")
-          | Some x ->
+          | _ ->
-            let data =
+            let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version vms in
-              Vmm_resources.fold (fun acc vm -> vm :: acc) [] x
-            in
-            let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in
             Ok (t, [ `Data out ], `End)
         end
       | Some Vmm_wire.Vm.Create ->
         Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config ->
         handle_create t hdr vm_config
+      | Some Vmm_wire.Vm.Force_create ->
+        Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config ->
+        let resources = Vmm_resources.remove t.resources vm_config.vname in
+        if Vmm_resources.check_vm_policy resources vm_config then
+          begin match Vmm_resources.find_vm t.resources id with
+            | None -> handle_create t hdr vm_config
+            | Some vm ->
+              Vmm_unix.destroy vm ;
+              let id_str = string_of_id id in
+              match String.Map.find_opt id_str t.tasks with
+              | None -> handle_create t hdr vm_config
+              | Some task ->
+                let tasks = String.Map.remove id_str t.tasks in
+                let t = { t with tasks } in
+                Ok (t, [], `Wait_and_create
+                      (t, task, fun t ->
+                          msg_to_err @@ handle_create t hdr vm_config))
+          end
+        else
+          Error (`Msg "wouldn't match policy")
       | Some Vmm_wire.Vm.Destroy ->
         match Vmm_resources.find_vm t.resources id with
         | Some vm ->

src/vmm_resources.ml

@@ -1,8 +1,5 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-open Astring
-open Rresult.R.Infix
-
 open Vmm_core
 
 type res_entry = {
@@ -10,118 +7,93 @@ type res_entry = {
   used_memory : int ;
 }
 
-let pp_res_entry ppf res =
-  Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory
-
 let empty_res = { running_vms = 0 ; used_memory = 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
+  succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory &&
+  vm_matches_res policy vm
+
+let check_resource_policy (policy : policy) (res : res_entry) =
+  res.running_vms <= policy.vms && res.used_memory <= policy.memory
 
 let add (vm : vm) (res : res_entry) =
   { running_vms = succ res.running_vms ;
     used_memory = vm.config.requested_memory + res.used_memory }
 
-let rem (vm : vm) (res : res_entry) =
-  { running_vms = pred res.running_vms ;
-    used_memory = res.used_memory - vm.config.requested_memory }
-
 type entry =
-  | Leaf of vm
+  | Vm of vm
-  | Subtree of res_entry * entry String.Map.t
+  | Policy of policy
 
-type t = entry String.Map.t
+type t = entry Vmm_trie.t
 
-let empty = String.Map.empty
+let empty = Vmm_trie.empty
 
-let check_dynamic m vm policies =
+let remove t name = Vmm_trie.remove name t
-  (* for each policy (string * delegation), we need to look that vm + dynamic <= delegation *)
-  let rec go m = function
-    | [] -> Ok ()
-    | (nam,delegation)::rest ->
-      match String.Map.find nam m with
-      | None -> Ok ()
-      | Some (Leaf _) -> Error (`Msg "didn't expect a leaf here")
-      | Some (Subtree (r, m)) ->
-        if check_resource delegation vm r then
-          go m rest
-        else
-          Error (`Msg ("overcommitted at " ^ nam))
-  in
-  go m policies
 
-let rec pp_entry ppf = function
+let fold t name f g acc =
-  | Leaf vm -> pp_vm ppf vm
+  Vmm_trie.fold name t (fun prefix entry acc ->
-  | Subtree (res, m) ->
+      match entry with
-    Fmt.pf ppf "%a %a"
+      | Vm vm -> f vm acc
-      pp_res_entry res
+      | Policy p -> g prefix p acc) acc
-      Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
-      (String.Map.bindings m)
 
-let pp ppf map =
+(* we should hide this type and confirm the following invariant:
-  Fmt.pf ppf "%a"
+   - in case Vm, there are no siblings *)
-    Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
-    (String.Map.bindings map)
 
-let find t name =
+let resource_usage t name =
-  let rec find r m = function
+  Vmm_trie.fold name t (fun _ entry acc ->
-    | [] -> Some (Subtree (r, m))
+      match entry with
-    | x::xs -> match String.Map.find x m with
+      | Policy _ -> acc
-      | None -> None
+      | Vm vm -> add vm acc)
-      | Some (Subtree (r, m)) -> find r m xs
+    empty_res
-      | Some (Leaf vm) -> Some (Leaf vm)
-  in
-  find empty_res t name
 
-let exists t name = match find t name with None -> false | Some _ -> true
+let find_vm t name = match Vmm_trie.find name t with
-
+  | Some (Vm vm) -> Some vm
-let find_vm t name = match find t name with
-  | Some (Leaf vm) -> Some vm
   | _ -> None
 
-let rec iter f = function
+let check_vm_policy t vm =
-  | Leaf vm -> f vm
+  let dom = domain vm.vname in
-  | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m)
+  let res = resource_usage t dom in
+  match Vmm_trie.find dom t with
+  | None -> true
+  | Some (Vm _) -> assert false
+  | Some (Policy p) -> check_resource p vm res
 
-let rec fold f acc = function
+let insert_vm t vm =
-  | Leaf vm -> f acc vm
+  if check_vm_policy t vm.config then
-  | Subtree (_, m) ->
+    match Vmm_trie.insert vm.config.vname (Vm vm) t with
-    List.fold_left (fun acc (_, e) -> fold f acc e) acc (String.Map.bindings m)
+    | t', None -> Ok t'
-
+    | _, Some _ -> Error (`Msg "vm already exists")
-let insert m name v =
-  let rec insert m = function
-    | [] -> Error (`Msg "ran out of labels during insert, this should not happen")
-    | [l] ->
-      begin match String.Map.find l m with
-        | None -> Ok (String.Map.add l (Leaf v) m)
-        | Some (Subtree _) -> Error (`Msg "found a subtree as last label")
-        | Some (Leaf _) -> Ok (String.Map.add l (Leaf v) m)
-      end
-    | l::ls ->
-      match String.Map.find l m with
-      | None ->
-        insert String.Map.empty ls >>= fun sub ->
-        Ok (String.Map.add l (Subtree (add v empty_res, sub)) m)
-      | Some (Subtree (r, m')) ->
-        insert m' ls >>= fun sub ->
-        Ok (String.Map.add l (Subtree (add v r, sub)) m)
-      | Some (Leaf _) -> Error (`Msg "should not happen: found leaf while still having labels")
-  in
-  insert m name
-
-let remove m name vm =
-  let rec del m = function
-    | [] -> Error (`Msg "should not happen: empty labels in remove")
-    | [l] -> Ok (String.Map.remove l m)
-    | l::ls -> match String.Map.find l m with
-      | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels")
-      | Some (Subtree (r, m')) ->
-        del m' ls >>= fun m' ->
-        if String.Map.is_empty m' then
-          Ok (String.Map.remove l m)
   else
-          let res = rem vm r in
+    Error (`Msg "resource policy mismatch")
-          Ok (String.Map.add l (Subtree (res, m')) m)
+
-      | Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels")
+let check_policy_above t name p =
-  in
+  let above = Vmm_trie.collect name t in
-  del m name
+  List.for_all (fun (_, node) -> match node with
+      | Vm _ -> assert false
+      | Policy p' -> is_sub ~super:p' ~sub:p)
+    above
+
+let check_policy_below t name p =
+  Vmm_trie.fold name t (fun name entry res ->
+      match name with
+      | [] -> res
+      | _ ->
+        match res, entry with
+        | Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error ()
+        | Ok p, Vm vm ->
+          (* TODO block device *)
+          if IS.mem vm.config.cpuid p.cpuids && good_bridge vm.config.network p.bridges then Ok p else Error ()
+        | res, _ -> res)
+    (Ok p)
+
+let insert_policy t name p =
+  let dom = domain name in
+  match
+    check_policy_above t dom p,
+    check_policy_below t name p,
+    check_resource_policy p (resource_usage t dom)
+  with
+  | true, Ok _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t))
+  | false, _, _ -> Error (`Msg "policy violates other policies above")
+  | _, Error (), _ -> Error (`Msg "policy violates other policies below")
+  | _, _, false -> Error (`Msg "more resources used than policy would allow")

src/vmm_resources.mli

@@ -1,6 +1,6 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-(** A tree data structure tracking dynamic resource usage.
+(** A tree data structure including policies and dynamic usage.
 
     Considering delegation of resources to someone, and further delegation
     to others - using a process which is not controlled by the authority -
@@ -14,43 +14,27 @@
 (** The type of the resource tree. *)
 type t
 
-(** The type of the resource tree entry. *)
-type entry
-
 (** [empty] is the empty tree. *)
 val empty : t
 
-(** [pp ppf t] pretty prints the tree. *)
-val pp : t Fmt.t
-
-(** [pp_entry ppf e] pretty prints the entry. *)
-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.policy) list ->
-  (unit, [> `Msg of string ]) result
-
-(** [exists t id] is [true] if the [id] already exists, [false] otherwise. *)
-val exists : t -> Vmm_core.id -> bool
-
-(** [find t id] is either [Some entry] or [None]. *)
-val find : t -> Vmm_core.id -> entry option
-
 (** [find_vm t id] is either [Some vm] or [None]. *)
 val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
 
-(** [iter f entry] applies [f] to each vm of [entry]. *)
+(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
-val iter : (Vmm_core.vm -> unit) -> entry -> unit
+    allowed under the current policies. *)
+val check_vm_policy : t -> Vmm_core.vm_config -> bool
 
-(** [fold f entry acc] folds [f] over [entry]. *)
+(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
-val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a
+    an error. *)
+val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result
 
-(** [insert t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
+(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
-    an error.  It also updates the resource usages on the path. *)
+   the new [t] or an error. *)
-val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
+val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
 
-(** [remove t id vm] removes [id] from [t], and returns the new [t] or an
+(** [remove t id] removes [id] from [t]. *)
-    error.  This also updates the resources usages on the path. *)
+val remove : t -> Vmm_core.id -> t
-val remove : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
+
+(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
+val fold : t -> Vmm_core.id -> (Vmm_core.vm -> 'a -> 'a) ->
+  (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a

src/vmm_trie.ml

@@ -77,3 +77,21 @@ let all t =
       acc' (String.Map.bindings m)
   in
   go [] [] t
+
+let fold id t f acc =
+  let rec explore (N (es, m)) prefix acc =
+    let acc' =
+      String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc)
+        m acc
+    in
+    match es with
+    | None -> acc'
+    | Some e -> f prefix e acc'
+  and down prefix (N (es, m)) =
+    match prefix with
+    | [] -> explore (N (es, m)) [] acc
+    | x :: xs -> match String.Map.find_opt x m with
+      | None -> acc
+      | Some n -> down xs n
+  in
+  down id t

src/vmm_trie.mli

@@ -13,3 +13,5 @@ val find : id -> 'a t -> 'a option
 val collect : id -> 'a t -> (id * 'a) list
 
 val all : 'a t -> (id * 'a) list
+
+val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b

src/vmm_wire.ml

@@ -546,19 +546,40 @@ module Vm = struct
     | Create
     | Destroy
     | Info
-    (* | Add_policy *)
+    | Policy
+    | Insert_policy
+    | Remove_policy
+    | Force_create
 
   let op_to_int = function
     | Create -> 0x0400l
     | Destroy -> 0x0401l
     | Info -> 0x0402l
+    | Policy -> 0x0403l
+    | Insert_policy -> 0x0404l
+    | Remove_policy -> 0x0405l
+    | Force_create -> 0x0406l
 
   let int_to_op = function
     | 0x0400l -> Some Create
     | 0x0401l -> Some Destroy
     | 0x0402l -> Some Info
+    | 0x0403l -> Some Policy
+    | 0x0404l -> Some Insert_policy
+    | 0x0405l -> Some Remove_policy
+    | 0x0406l -> Some Force_create
     | _ -> None
 
+  let policy id version name =
+    encode ~name version id (op_to_int Policy)
+
+  let insert_policy id version name policy =
+    let body = Vmm_asn.policy_to_cstruct policy in
+    encode ~name ~body version id (op_to_int Insert_policy)
+
+  let remove_policy id version name =
+    encode ~name version id (op_to_int Remove_policy)
+
   let info id version name =
     encode ~name version id (op_to_int Info)
 
@@ -575,6 +596,25 @@ module Vm = struct
     let body = encode_list encode_vm vms in
     reply ~body version id (op_to_int Info)
 
+  let policy_reply id version policies =
+    let body = encode_list
+        (fun (prefix, policy) ->
+           let name_cs = encode_strings prefix
+           and pol_cs = Vmm_asn.policy_to_cstruct policy in
+           Cstruct.append name_cs pol_cs)
+        policies
+    in
+    reply ~body version id (op_to_int Policy)
+
+  let decode_policies buf =
+    decode_list (fun cs ->
+        decode_strings cs >>= fun (id, l) ->
+        cs_shift cs l >>= fun cs' ->
+        Vmm_asn.policy_of_cstruct cs' >>= fun (policy, cs'') ->
+        let off = Cstruct.len cs - Cstruct.len cs'' in
+        Ok ((id, policy), off))
+      buf
+
   let decode_vm cs =
     decode_strings cs >>= fun (id, l) ->
     cs_shift cs l >>= fun cs' ->
@@ -632,124 +672,10 @@ module Vm = struct
     let body = encode_vm_config vm in
     encode ~name:vm.vname ~body version id (op_to_int Create)
 
+  let force_create id version vm =
+    let body = encode_vm_config vm in
+    encode ~name:vm.vname ~body version id (op_to_int Force_create)
+
   let destroy id version name =
     encode ~name version id (op_to_int Destroy)
 end
-
-(*
-module Client = struct
-  let cmd_to_int = function
-    | Info -> 0x0500l
-    | Destroy_vm -> 0x0501l
-    | Create_block -> 0x0502l
-    | Destroy_block -> 0x0503l
-    | Statistics -> 0x0504l
-    | Attach -> 0x0505l
-    | Detach -> 0x0506l
-    | Log -> 0x0507l
-  and cmd_of_int = function
-    | 0x0500l -> Some Info
-    | 0x0501l -> Some Destroy_vm
-    | 0x0502l -> Some Create_block
-    | 0x0503l -> Some Destroy_block
-    | 0x0504l -> Some Statistics
-    | 0x0505l -> Some Attach
-    | 0x0506l -> Some Detach
-    | 0x0507l -> Some Log
-    | _ -> None
-
-  let cmd ?arg it id version =
-    let pay, length = may_enc_str arg
-    and tag = cmd_to_int it
-    in
-    let length = Int32.of_int length in
-    let hdr = create_header { length ; id ; version ; tag } in
-    Cstruct.(to_string (append hdr pay))
-
-  let log hdr event version =
-    let payload =
-      Cstruct.append
-        (Log.encode_log_hdr ~drop_context:true hdr)
-        (Log.encode_event event)
-    in
-    let length = cs_len payload in
-    let r =
-      Cstruct.append
-        (create_header { length ; id = 0L ; version ; tag = Log.(op_to_int Data) })
-        payload
-    in
-    Cstruct.to_string r
-
-  let stat data id version =
-    let length = Int32.of_int (String.length data) in
-    let hdr = create_header { length ; id ; version ; tag = Stats.(op_to_int Stat_reply) } in
-    Cstruct.to_string hdr ^ data
-
-  let console off name payload version =
-    let name = match List.rev (id_of_string name) with
-      | leaf::_ -> leaf
-      | [] -> "none"
-    in
-    let nam, l = encode_string name in
-    let payload, length =
-      let p' = Astring.String.drop ~max:off payload in
-      p', l + String.length p'
-    in
-    let length = Int32.of_int length in
-    let hdr =
-      create_header { length ; id = 0L ; version ; tag = Console.(op_to_int Data) }
-    in
-    Cstruct.(to_string (append hdr nam)) ^ payload
-
-  let encode_vm name vm =
-    let name = encode_string name
-    and cs = encode_string (Bos.Cmd.to_string vm.cmd)
-    and pid = encode_int vm.pid
-    and taps = encode_strings vm.taps
-    in
-    let tapc = encode_int (Cstruct.len taps) in
-    let r = Cstruct.concat [ name ; cs ; pid ; tapc ; taps ] in
-    Cstruct.to_string r
-
-  let info data id version =
-    let length = String.length data in
-    let length = Int32.of_int length in
-    let hdr = create_header { length ; id ; version ; tag = success_tag } in
-    Cstruct.to_string hdr ^ data
-
-  let decode_vm cs =
-    decode_string cs >>= fun (name, l) ->
-    decode_string (Cstruct.shift cs l) >>= fun (cmd, l') ->
-    decode_int (Cstruct.shift cs (l + l')) >>= fun pid ->
-    decode_int ~off:(l + l' + 4) cs >>= fun tapc ->
-    let taps = Cstruct.sub cs (l + l' + 12) tapc in
-    decode_strings taps >>= fun taps ->
-    Ok ((name, cmd, pid, taps), Cstruct.shift cs (l + l' + 12 + tapc))
-
-  let decode_info data =
-    let rec go acc buf =
-      if Cstruct.len buf = 0 then
-        Ok (List.rev acc)
-      else
-        decode_vm buf >>= fun (vm, rest) ->
-        go (vm :: acc) rest
-    in
-    go [] (Cstruct.of_string data)
-
-  let decode_stat data =
-    Stats.decode_stats (Cstruct.of_string data)
-
-  let decode_log data =
-    let cs = Cstruct.of_string data in
-    Log.decode_log_hdr cs >>= fun (hdr, rest) ->
-    Log.decode_event rest >>= fun event ->
-    Ok (hdr, event)
-
-  let decode_console data =
-    let cs = Cstruct.of_string data in
-    decode_string cs >>= fun (name, l) ->
-    decode_ptime (Cstruct.shift cs l) >>= fun ts ->
-    decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) ->
-    Ok (name, ts, line)
-end
-                *)