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

policies:

Browse source 
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.
This commit is contained in:
Hannes Mehnert 2018-10-13 01:05:21 +02:00
parent ea83013068
commit 182e2ae10c
11 changed files with 483 additions and 347 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

158
app/vmmc.ml
View file

@ -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
let destroy _ opt_socket name =
Lwt_main.run (really_destroy opt_socket name) ;
Vmm_lwt.safe_close fd) ;
`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

96
app/vmmd.ml
View file

@ -22,44 +22,9 @@ type out = [
| `Log of Cstruct.t
]
let handle state 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
| `Create cont ->
(* data contained a write to console, we need to wait for its reply first *)
let state = ref (Vmm_engine.init ())
let create c_fd process cont =
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 ())

32
src/vmm_asn.ml
View file

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

9
src/vmm_asn.mli
View file

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

15
src/vmm_core.ml
View file

@ -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 path name = Fpath.(to_string (tmpdir / "util" / name + "sock")) in
function
let socket_path t =
let path name = Fpath.(tmpdir / "util" / name + "sock") in
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

94
src/vmm_engine.ml
View file

@ -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 *) =
(if Vmm_resources.exists t.resources vm_config.vname then
Error (`Msg "VM with same name is already running")
let handle_create t hdr vm_config =
(match Vmm_resources.find_vm t.resources vm_config.vname with
| 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 () ->
(* Logs.debug (fun m -> m "now checking dynamic policies") ;
Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *)
Error (`Msg "resource policies don't allow this")) >>= 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 =
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 resources = Vmm_resources.remove t.resources vm.config.vname 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
| None ->
let vms =
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 =
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
| _ ->
let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version vms 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 ->

168
src/vmm_resources.ml
View file

@ -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
| Subtree of res_entry * entry String.Map.t
| Vm of vm
| 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 =
(* 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 remove t name = Vmm_trie.remove name t
let rec pp_entry ppf = function
| Leaf vm -> pp_vm ppf vm
| Subtree (res, m) ->
Fmt.pf ppf "%a %a"
pp_res_entry res
Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
(String.Map.bindings m)
let fold t name f g acc =
Vmm_trie.fold name t (fun prefix entry acc ->
match entry with
| Vm vm -> f vm acc
| Policy p -> g prefix p acc) acc
let pp ppf map =
Fmt.pf ppf "%a"
Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
(String.Map.bindings map)
(* we should hide this type and confirm the following invariant:
- in case Vm, there are no siblings *)
let find t name =
let rec find r m = function
| [] -> Some (Subtree (r, m))
| x::xs -> match String.Map.find x m with
| None -> None
| Some (Subtree (r, m)) -> find r m xs
| Some (Leaf vm) -> Some (Leaf vm)
in
find empty_res t name
let resource_usage t name =
Vmm_trie.fold name t (fun _ entry acc ->
match entry with
| Policy _ -> acc
| Vm vm -> add vm acc)
empty_res
let exists t name = match find t name with None -> false | Some _ -> true
let find_vm t name = match find t name with
| Some (Leaf vm) -> Some vm
let find_vm t name = match Vmm_trie.find name t with
| Some (Vm vm) -> Some vm
| _ -> None
let rec iter f = function
| Leaf vm -> f vm
| Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m)
let check_vm_policy t vm =
let dom = domain vm.vname in
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
| Leaf vm -> f acc vm
| Subtree (_, m) ->
List.fold_left (fun acc (_, e) -> fold f acc e) acc (String.Map.bindings m)
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)
let insert_vm t vm =
if check_vm_policy t vm.config then
match Vmm_trie.insert vm.config.vname (Vm vm) t with
| t', None -> Ok t'
| _, Some _ -> Error (`Msg "vm already exists")
else
let res = rem vm r in
Ok (String.Map.add l (Subtree (res, m')) m)
| Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels")
in
del m name
Error (`Msg "resource policy mismatch")
let check_policy_above t name p =
let above = Vmm_trie.collect name t in
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")

48
src/vmm_resources.mli
View file

@ -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]. *)
val iter : (Vmm_core.vm -> unit) -> entry -> unit
(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.vm_config -> bool
(** [fold f entry acc] folds [f] over [entry]. *)
val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a
(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
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
an error. It also updates the resource usages on the path. *)
val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
the new [t] or an error. *)
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
error. This also updates the resources usages on the path. *)
val remove : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [remove t id] removes [id] from [t]. *)
val remove : t -> Vmm_core.id -> t
(** [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

18
src/vmm_trie.ml
View file

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

2
src/vmm_trie.mli
View file

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

164
src/vmm_wire.ml
View file

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