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

block device support

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-10 01:02:07 +01:00
parent 6945d21422
commit 6dcde8eb68
15 changed files with 551 additions and 174 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
app/vmm_cli.ml
View file

@ -120,9 +120,21 @@ let vm_name =
let doc = "Name virtual machine." in
Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"VM")
let block_name =
let doc = "Name of block device." in
Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"BLOCK")
let block_size =
let doc = "Block size in MB." in
Arg.(required & pos 1 (some int) None & info [] ~doc ~docv:"SIZE")
let opt_block_name =
let doc = "Name of block device." in
Arg.(value & opt vm_c [] & info [ "name" ] ~doc)
let opt_block_size =
let doc = "Block storage to allow in MB" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
Arg.(value & opt (some int) None & info [ "size" ] ~doc)
let mem =
let doc = "Memory to allow in MB" in

2
app/vmm_stats_stubs.c
View file

@ -40,11 +40,11 @@ CAMLprim value vmmanage_sysctl_rusage (value pid_r) {
if (error < 0)
uerror("sysctl", Nothing);
ru = p.ki_rusage;
if (ru.ru_utime.tv_usec < 0 || ru.ru_utime.tv_usec > 999999999 ||
ru.ru_stime.tv_usec < 0 || ru.ru_stime.tv_usec > 999999999)
uerror("sysctl", Nothing);
ru = p.ki_rusage;
utime = caml_alloc(2, 0);
Store_field (utime, 0, Val64(ru.ru_utime.tv_sec));
Store_field (utime, 1, Val_int(ru.ru_utime.tv_usec));

44
app/vmmc_bistro.ml
View file

@ -93,6 +93,15 @@ let stats _ endp cert key ca name =
let event_log _ endp cert key ca name since =
jump endp cert key ca name (`Log_cmd (`Log_subscribe since))
let block_info _ endp cert key ca block_name =
jump endp cert key ca block_name (`Block_cmd `Block_info)
let block_create _ endp cert key ca block_name block_size =
jump endp cert key ca block_name (`Block_cmd (`Block_add block_size))
let block_destroy _ endp cert key ca block_name =
jump endp cert key ca block_name (`Block_cmd `Block_remove)
let help _ _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
@ -159,7 +168,7 @@ let add_policy_cmd =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
Term.info "add_policy" ~doc ~man
let create_cmd =
@ -198,6 +207,33 @@ let log_cmd =
Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)),
Term.info "log" ~doc ~man
let block_info_cmd =
let doc = "Information about block devices" in
let man =
[`S "DESCRIPTION";
`P "Block device information."]
in
Term.(ret (const block_info $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_block_name)),
Term.info "block" ~doc ~man
let block_create_cmd =
let doc = "Create a block device" in
let man =
[`S "DESCRIPTION";
`P "Creation of a block device."]
in
Term.(ret (const block_create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name $ block_size)),
Term.info "create_block" ~doc ~man
let block_destroy_cmd =
let doc = "Destroys a block device" in
let man =
[`S "DESCRIPTION";
`P "Destroys a block device."]
in
Term.(ret (const block_destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name)),
Term.info "destroy_block" ~doc ~man
let help_cmd =
let topic =
let doc = "The topic to get help on. `topics' lists the topics." in
@ -220,7 +256,11 @@ let default_cmd =
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man
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 cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ; stats_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds

44
app/vmmc_local.ml
View file

@ -72,6 +72,15 @@ let stats _ opt_socket name =
let event_log _ opt_socket name since =
jump opt_socket name (`Log_cmd (`Log_subscribe since))
let block_info _ opt_socket block_name =
jump opt_socket block_name (`Block_cmd `Block_info)
let block_create _ opt_socket block_name block_size =
jump opt_socket block_name (`Block_cmd (`Block_add block_size))
let block_destroy _ opt_socket block_name =
jump opt_socket block_name (`Block_cmd `Block_remove)
let help _ _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
@ -126,7 +135,7 @@ let add_policy_cmd =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
Term.info "add_policy" ~doc ~man
let create_cmd =
@ -165,6 +174,33 @@ let log_cmd =
Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)),
Term.info "log" ~doc ~man
let block_info_cmd =
let doc = "Information about block devices" in
let man =
[`S "DESCRIPTION";
`P "Block device information."]
in
Term.(ret (const block_info $ setup_log $ socket $ opt_block_name)),
Term.info "block" ~doc ~man
let block_create_cmd =
let doc = "Create a block device" in
let man =
[`S "DESCRIPTION";
`P "Creation of a block device."]
in
Term.(ret (const block_create $ setup_log $ socket $ block_name $ block_size)),
Term.info "create_block" ~doc ~man
let block_destroy_cmd =
let doc = "Destroys a block device" in
let man =
[`S "DESCRIPTION";
`P "Destroys a block device."]
in
Term.(ret (const block_destroy $ setup_log $ socket $ block_name)),
Term.info "destroy_block" ~doc ~man
let help_cmd =
let topic =
let doc = "The topic to get help on. `topics' lists the topics." in
@ -187,7 +223,11 @@ let default_cmd =
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
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 cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ; stats_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds

44
app/vmmp_request.ml
View file

@ -54,6 +54,15 @@ let stats _ name =
let event_log _ name since =
jump name (`Log_cmd (`Log_subscribe since))
let block_info _ block_name =
jump block_name (`Block_cmd `Block_info)
let block_create _ block_name block_size =
jump block_name (`Block_cmd (`Block_add block_size))
let block_destroy _ block_name =
jump block_name (`Block_cmd `Block_remove)
let help _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
@ -104,7 +113,7 @@ let add_policy_cmd =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
Term.info "add_policy" ~doc ~man
let create_cmd =
@ -143,6 +152,33 @@ let log_cmd =
Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)),
Term.info "log" ~doc ~man
let block_info_cmd =
let doc = "Information about block devices" in
let man =
[`S "DESCRIPTION";
`P "Block device information."]
in
Term.(ret (const block_info $ setup_log $ opt_block_name)),
Term.info "block" ~doc ~man
let block_create_cmd =
let doc = "Create a block device" in
let man =
[`S "DESCRIPTION";
`P "Creation of a block device."]
in
Term.(ret (const block_create $ setup_log $ block_name $ block_size)),
Term.info "create_block" ~doc ~man
let block_destroy_cmd =
let doc = "Destroys a block device" in
let man =
[`S "DESCRIPTION";
`P "Destroys a block device."]
in
Term.(ret (const block_destroy $ setup_log $ block_name)),
Term.info "destroy_block" ~doc ~man
let help_cmd =
let topic =
let doc = "The topic to get help on. `topics' lists the topics." in
@ -165,7 +201,11 @@ let default_cmd =
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
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 cmds = [ help_cmd ; info_cmd ;
policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
destroy_cmd ; create_cmd ;
block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
console_cmd ; stats_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds

34
src/vmm_asn.ml
View file

@ -305,6 +305,22 @@ let policy_cmd =
(explicit 1 policy)
(explicit 2 null))
let block_cmd =
let f = function
| `C1 () -> `Block_info
| `C2 size -> `Block_add size
| `C3 () -> `Block_remove
and g = function
| `Block_info -> `C1 ()
| `Block_add size -> `C2 size
| `Block_remove -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 null)
(explicit 1 int)
(explicit 2 null))
let version =
let f data = match data with
| 2 -> `AV2
@ -321,20 +337,23 @@ let wire_command =
| `C3 log -> `Log_cmd log
| `C4 vm -> `Vm_cmd vm
| `C5 policy -> `Policy_cmd policy
| `C6 block -> `Block_cmd block
and g = function
| `Console_cmd c -> `C1 c
| `Stats_cmd c -> `C2 c
| `Log_cmd c -> `C3 c
| `Vm_cmd c -> `C4 c
| `Policy_cmd c -> `C5 c
| `Block_cmd c -> `C6 c
in
Asn.S.map f g @@
Asn.S.(choice5
Asn.S.(choice6
(explicit 0 console_cmd)
(explicit 1 stats_cmd)
(explicit 2 log_cmd)
(explicit 3 vm_cmd)
(explicit 4 policy_cmd))
(explicit 4 policy_cmd)
(explicit 5 block_cmd))
let data =
let f = function
@ -378,14 +397,16 @@ let success =
| `C2 str -> `String str
| `C3 policies -> `Policies policies
| `C4 vms -> `Vms vms
| `C5 blocks -> `Blocks blocks
and g = function
| `Empty -> `C1 ()
| `String s -> `C2 s
| `Policies ps -> `C3 ps
| `Vms vms -> `C4 vms
| `Blocks blocks -> `C5 blocks
in
Asn.S.map f g @@
Asn.S.(choice4
Asn.S.(choice5
(explicit 0 null)
(explicit 1 utf8_string)
(explicit 2 (sequence_of
@ -395,7 +416,12 @@ let success =
(explicit 3 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"vm_config" vm_config)))))
(required ~label:"vm_config" vm_config))))
(explicit 4 (sequence_of
(sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"size" int)
(required ~label:"active" bool)))))
let payload =
let f = function

32
src/vmm_commands.ml
View file

@ -55,8 +55,8 @@ type vm_cmd = [
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
| `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
| `Vm_create vm_config -> Fmt.pf ppf "vm create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" pp_vm_config vm_config
| `Vm_destroy -> Fmt.string ppf "vm destroy"
type policy_cmd = [
@ -67,15 +67,27 @@ type policy_cmd = [
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
| `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy
| `Policy_remove -> Fmt.string ppf "policy remove"
type block_cmd = [
| `Block_info
| `Block_add of int
| `Block_remove
]
let pp_block_cmd ppf = function
| `Block_info -> Fmt.string ppf "block info"
| `Block_add size -> Fmt.pf ppf "block add %d" size
| `Block_remove -> Fmt.string ppf "block remove"
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd
| `Block_cmd of block_cmd
]
let pp ppf = function
@ -84,6 +96,7 @@ let pp ppf = function
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
| `Block_cmd b -> pp_block_cmd ppf b
type data = [
| `Console_data of Ptime.t * string
@ -103,13 +116,23 @@ type header = {
id : id ;
}
type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
| `Blocks of (id * int * bool) list
]
let pp_block ppf (id, size, active) =
Fmt.pf ppf "block %a size %d MB active %B" pp_id 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 ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
| `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
type wire = header * [
| `Command of t
@ -128,6 +151,7 @@ let pp_wire ppf (header, data) =
let endpoint = function
| `Vm_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End
| `Block_cmd _ -> `Vmmd, `End
| `Stats_cmd _ -> `Stats, `Read
| `Console_cmd _ -> `Console, `Read
| `Log_cmd _ -> `Log, `Read

11
src/vmm_commands.mli
View file

@ -39,12 +39,20 @@ type policy_cmd = [
| `Policy_remove
]
type block_cmd = [
| `Block_info
| `Block_add of int
| `Block_remove
]
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd ]
| `Policy_cmd of policy_cmd
| `Block_cmd of block_cmd
]
val pp : t Fmt.t
@ -67,6 +75,7 @@ type success = [
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
| `Blocks of (id * int * bool) list
]
type wire = header * [

8
src/vmm_core.ml
View file

@ -1,4 +1,4 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Astring
@ -6,6 +6,7 @@ open Rresult.R.Infix
let tmpdir = Fpath.(v "/var" / "run" / "albatross")
let dbdir = Fpath.(v "/var" / "db" / "albatross")
let blockdir = Fpath.(dbdir / "block")
type service = [ `Console | `Log | `Stats | `Vmmd ]
@ -60,6 +61,8 @@ let domain id = match List.rev id with
| _::prefix -> List.rev prefix
| [] -> []
let block_name vm_name dev = List.rev (dev :: List.rev (domain vm_name))
let pp_id ppf ids =
Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
@ -194,8 +197,9 @@ type vm = {
}
let pp_vm ppf vm =
Fmt.pf ppf "pid %d@ taps %a cmdline %a"
Fmt.pf ppf "pid %d@ taps %a (block %a) cmdline %a"
vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps
Fmt.(option ~none:(unit "no") string) vm.config.block_device
Bos.Cmd.pp vm.cmd
let translate_tap vm tap =

12
src/vmm_core.mli
View file

@ -2,6 +2,7 @@
val tmpdir : Fpath.t
val dbdir : Fpath.t
val blockdir : Fpath.t
type service = [ `Console | `Log | `Stats | `Vmmd ]
@ -20,12 +21,13 @@ module IM : sig
end
type id = string list
val string_of_id : string list -> string
val id_of_string : string -> string list
val drop_super : super:string list -> sub:string list -> string list option
val is_sub_id : super:string list -> sub:string list -> bool
val domain : 'a list -> 'a list
val string_of_id : id -> string
val id_of_string : string -> id
val drop_super : super:id -> sub:id -> id option
val is_sub_id : super:id -> sub:id -> bool
val domain : id -> id
val pp_id : id Fmt.t
val block_name : id -> string -> id
type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int

104
src/vmm_resources.ml
View file

@ -5,9 +5,10 @@ open Vmm_core
type res_entry = {
running_vms : int ;
used_memory : int ;
used_blockspace : int ;
}
let empty_res = { running_vms = 0 ; used_memory = 0 }
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 &&
@ -15,41 +16,47 @@ let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
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 }
res.running_vms <= policy.vms && res.used_memory <= policy.memory &&
match 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
let pp_entry id ppf = function
| Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p
| Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." pp_id id size used
type t = entry Vmm_trie.t
let pp ppf t =
Vmm_trie.fold [] t
(fun id ele () -> match ele with
| Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p)
()
(fun id ele () -> pp_entry id ppf ele) ()
let empty = Vmm_trie.empty
let fold t name f g acc =
let fold t name f g h acc =
Vmm_trie.fold name t (fun prefix entry acc ->
match entry with
| Vm vm -> f prefix vm acc
| Policy p -> g prefix p acc) acc
| Policy p -> g prefix p acc
| Block (size, used) -> h prefix size used acc) acc
(* we should hide this type and confirm the following invariant:
- in case Vm, there are no siblings *)
let resource_usage t name =
Vmm_trie.fold name t (fun _ entry acc ->
Vmm_trie.fold name t (fun _ entry res ->
match entry with
| Policy _ -> acc
| Vm vm -> add vm acc)
| Policy _ -> res
| Block (size, _) -> { res with used_blockspace = res.used_blockspace + size }
| Vm vm ->
{ res with running_vms = succ res.running_vms ;
used_memory = vm.config.requested_memory + res.used_memory })
empty_res
let find_vm t name = match Vmm_trie.find name t with
@ -60,42 +67,61 @@ let find_policy t name = match Vmm_trie.find name t with
| Some (Policy p) -> Some p
| _ -> None
let find_block t name = match Vmm_trie.find name t with
| Some (Block (size, active)) -> Some (size, active)
| _ -> None
let set_block_usage active t name vm =
match vm.config.block_device with
| None -> Ok t
| Some block ->
let block_name = block_name name block in
match find_block t block_name with
| None -> Error (`Msg "unknown block device")
| Some (size, curr) ->
if curr = active then
Error (`Msg "failed because the requested block usage was already set")
else
Ok (fst (Vmm_trie.insert block_name (Block (size, active)) t))
let remove_vm t name = match find_vm t name with
| None -> Error (`Msg "unknown vm")
| Some _ -> Ok (Vmm_trie.remove name t)
| Some vm -> set_block_usage false (Vmm_trie.remove name t) name vm
let remove_policy t name = match find_policy t name with
| None -> Error (`Msg "unknown policy")
| Some _ -> Ok (Vmm_trie.remove name t)
let remove_block t name = match find_block t name with
| None -> Error (`Msg "unknown block")
| Some _ -> Ok (Vmm_trie.remove name t)
let check_vm_policy t name vm =
let dom = domain name in
let res = resource_usage t dom in
match Vmm_trie.find dom t with
| None -> Ok true
| Some (Vm vm) ->
Logs.err (fun m -> m "id %a, expected policy, got vm %a" pp_id dom pp_vm vm) ;
Rresult.R.error_msgf "expected policy, found vm for %a" pp_id dom
| Some (Policy p) -> Ok (check_resource p vm res)
| Some x ->
Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" pp_id dom
let insert_vm t name vm =
let open Rresult.R.Infix in
check_vm_policy t name vm.config >>= function
| true ->
begin match Vmm_trie.insert name (Vm vm) t with
| t', None -> Ok t'
| _, Some _ -> Error (`Msg "vm already exists")
end
| false -> Error (`Msg "resource policy mismatch")
| true -> match Vmm_trie.insert name (Vm vm) t with
| t', None -> set_block_usage true t' name vm
| _, Some _ -> Error (`Msg "vm already exists")
let check_policy_above t name p =
let above = Vmm_trie.collect name t in
List.for_all (fun (id, node) -> match node with
| Vm vm ->
Logs.err (fun m -> m "found vm %a, expecting a policy at %a"
pp_vm vm pp_id id) ;
false
| Policy p' -> is_sub ~super:p' ~sub:p)
| Policy p' -> is_sub ~super:p' ~sub:p
| x ->
Logs.err (fun m -> m "expected policy, found %a"
(pp_entry id) x) ;
false)
above
let check_policy_below t name p =
@ -123,3 +149,23 @@ let insert_policy t name p =
| false, _, _ -> Error (`Msg "policy violates other policies above")
| _, None, _ -> Error (`Msg "policy violates other policies below")
| _, _, false -> Error (`Msg "more resources used than policy would allow")
let check_block_policy t name size =
match find_block t name with
| Some _ -> Error (`Msg "block device with same name already exists")
| None ->
let dom = domain name in
let res = resource_usage t dom in
let res' = { res with used_blockspace = res.used_blockspace + size } in
match Vmm_trie.find dom t with
| None -> Ok true
| Some (Policy p) -> Ok (check_resource_policy p res')
| Some x ->
Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
Rresult.R.error_msgf "expected policy for %a" pp_id dom
let insert_block t name size =
let open Rresult.R.Infix in
check_block_policy t name size >>= function
| false -> Error (`Msg "resource policy mismatch")
| true -> Ok (fst (Vmm_trie.insert name (Block (size, false)) t))

23
src/vmm_resources.mli
View file

@ -23,11 +23,14 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
(** [find_policy t id] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
(** [find_block t id] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.id -> (int * bool) option
(** [check_vm_policy t id vm] checks whether [vm] under [id] in [t] would be
allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
(** [insert_vm t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
an error. *)
val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
@ -35,16 +38,28 @@ val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) resul
the new [t] or an error. *)
val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
(** [check_block_policy t id size] checks whether [size] under [id] in [t] would be
allowed under the current policies. *)
val check_block_policy : t -> Vmm_core.id -> int -> (bool, [> `Msg of string ]) result
(** [insert_block t id size] inserts [size] under [id] in [t], and returns the new [t] or
an error. *)
val insert_block : t -> Vmm_core.id -> int -> (t, [> `Msg of string]) result
(** [remove_vm t id] removes vm [id] from [t]. *)
val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [remove_policy t id] removes policy [id] from [t]. *)
val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
(** [remove_block t id] removes block [id] from [t]. *)
val remove_block : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [fold t id f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [id] over [t]. *)
val fold : t -> Vmm_core.id ->
(Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a
(Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) ->
(Vmm_core.id -> int -> bool -> 'a -> 'a) -> 'a -> 'a
(** [pp] is a pretty printer for [t]. *)
val pp : t Fmt.t

69
src/vmm_unix.ml
View file

@ -145,17 +145,24 @@ let cpuset cpu =
Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x))
let exec name vm taps =
let net = List.map (fun t -> "--net=" ^ t) taps in
let argv = match vm.argv with None -> [] | Some xs -> xs in
(match taps with
| [] -> Ok Fpath.(dbdir / "solo5-hvt.none")
| [_] -> Ok Fpath.(dbdir / "solo5-hvt.net")
| _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
let block_device_name name = Fpath.(blockdir / string_of_id name)
let exec name vm taps block =
(match taps, block with
| [], None -> Ok "none"
| [_], None -> Ok "net"
| [], Some _ -> Ok "block"
| [_], Some _ -> Ok "block-net"
| _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
let net = List.map (fun t -> "--net=" ^ t) taps
and block = match block with None -> [] | Some dev -> [ "--disk=" ^ Fpath.to_string (block_device_name dev) ]
and argv = match vm.argv with None -> [] | Some xs -> xs
and mem = "--mem=" ^ string_of_int vm.requested_memory
in
cpuset vm.cpuid >>= fun cpuset ->
let mem = "--mem=" ^ string_of_int vm.requested_memory in
let cmd =
Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
of_list net %% of_list block %
"--" % p (image_file name) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in
@ -178,3 +185,47 @@ let exec name vm taps =
R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)
let bytes_of_mb size =
let res = size lsl 20 in
if res > size then
Ok res
else
Error (`Msg "overflow while computing bytes")
let create_block name size =
let block_name = block_device_name name in
Bos.OS.File.exists block_name >>= function
| true -> Error (`Msg "file already exists")
| false ->
bytes_of_mb size >>= fun size' ->
Bos.OS.File.truncate block_name size'
let destroy_block name =
Bos.OS.File.delete (block_device_name name)
let mb_of_bytes size =
if size = 0 || size land 0xFFFFF <> 0 then
Error (`Msg "size is either 0 or not MB aligned")
else
Ok (size lsr 20)
let find_block_devices () =
Bos.OS.Dir.contents ~rel:true blockdir >>= fun files ->
List.fold_left (fun acc file ->
acc >>= fun acc ->
let path = Fpath.append blockdir file in
Bos.OS.File.exists path >>= function
| false ->
Logs.warn (fun m -> m "file %a doesn't exist, but was listed" Fpath.pp path) ;
Ok acc
| true ->
Bos.OS.Path.stat path >>= fun stats ->
match mb_of_bytes stats.Unix.st_size with
| Error (`Msg msg) ->
Logs.warn (fun m -> m "file %a error: %s" Fpath.pp path msg) ;
Ok acc
| Ok size ->
let id = id_of_string (Fpath.to_string file) in
Ok ((id, size) :: acc))
(Ok []) files

8
src/vmm_unix.mli
View file

@ -8,8 +8,14 @@ val prepare : id -> vm_config -> (string list, [> R.msg ]) result
val shutdown : id -> vm -> (unit, [> R.msg ]) result
val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
val exec : id -> vm_config -> string list -> string list option -> (vm, [> R.msg ]) result
val destroy : vm -> unit
val close_no_err : Unix.file_descr -> unit
val create_block : id -> int -> (unit, [> R.msg ]) result
val destroy_block : id -> (unit, [> R.msg ]) result
val find_block_devices : unit -> ((id * int) list, [> R.msg ]) result

128
src/vmm_vmmd.ml
View file

@ -16,14 +16,30 @@ type 'a t = {
tasks : 'a String.Map.t ;
}
let init wire_version = {
let init wire_version =
let t = {
wire_version ;
console_counter = 1L ;
stats_counter = 1L ;
log_counter = 1L ;
resources = Vmm_resources.empty ;
tasks = String.Map.empty ;
}
} in
match Vmm_unix.find_block_devices () with
| Error (`Msg msg) ->
Logs.warn (fun m -> m "couldn't find block devices %s" msg) ;
t
| Ok devs ->
let resources =
List.fold_left (fun r (id, size) ->
match Vmm_resources.insert_block r id size with
| Error (`Msg msg) ->
Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" pp_id id size msg) ;
r
| Ok r -> r)
t.resources devs
in
{ t with resources }
type service_out = [
| `Stat of Vmm_commands.wire
@ -40,15 +56,23 @@ let log t id event =
Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, `Log (header, `Data (`Log_data data)))
let handle_create t hdr vm_config =
let name = hdr.Vmm_commands.id in
let handle_create t reply name vm_config =
(match Vmm_resources.find_vm t.resources name with
| Some _ -> Error (`Msg "VM with same name is already running")
| None -> Ok ()) >>= fun () ->
Logs.debug (fun m -> m "now checking resource policies") ;
(Vmm_resources.check_vm_policy t.resources name vm_config >>= function
| false -> Error (`Msg "resource policies don't allow this")
| false -> Error (`Msg "resource policies don't allow creation of this VM")
| true -> Ok ()) >>= fun () ->
(match vm_config.block_device with
| None -> Ok None
| Some dev ->
let block_device_name = block_name name dev in
Logs.debug (fun m -> m "looking for block device %a" pp_id block_device_name) ;
match Vmm_resources.find_block t.resources block_device_name with
| Some (_, false) -> Ok (Some block_device_name)
| Some (_, true) -> Error (`Msg "block device is busy")
| None -> Error (`Msg "cannot find block device") ) >>= fun block_device ->
(* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
@ -60,14 +84,13 @@ let handle_create t hdr vm_config =
[ `Cons cons_out ],
`Create (fun t task ->
(* actually execute the vm *)
Vmm_unix.exec name vm_config taps >>= fun vm ->
Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (string_of_id name) task t.tasks in
let t = { t with resources ; tasks } in
let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in
let data = `Success (`String "created VM") in
Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in
@ -92,21 +115,9 @@ let handle_shutdown t name vm r =
in
(t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
let handle_command t (header, payload) =
let msg_to_err = function
| Ok x -> x
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing command: %s" msg) ;
(t, [ `Data (header, `Failure msg) ], `End)
in
let reply x = `Data (header, `Success x) in
msg_to_err (
let id = header.Vmm_commands.id in
match payload with
| `Command (`Policy_cmd pc) ->
begin match pc with
let handle_policy_cmd t reply id = function
| `Policy_remove ->
Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
Logs.debug (fun m -> m "remove policy %a" pp_id id) ;
Vmm_resources.remove_policy t.resources id >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
| `Policy_add policy ->
@ -121,12 +132,12 @@ let handle_command t (header, payload) =
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
| `Policy_info ->
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)
(fun _ _ _ policies -> policies)
[]
in
match policies with
@ -135,16 +146,15 @@ let handle_command t (header, payload) =
Error (`Msg "policy: not found")
| _ ->
Ok (t, [ reply (`Policies policies) ], `End)
end
end
| `Command (`Vm_cmd vc) ->
begin match vc with
let handle_vm_cmd t reply id msg_to_err = function
| `Vm_info ->
Logs.debug (fun m -> m "info %a" pp_id id) ;
let vms =
Vmm_resources.fold t.resources id
(fun id vm vms -> (id, vm.config) :: vms)
(fun _ _ vms-> vms)
(fun _ _ _ vms -> vms)
[]
in
begin match vms with
@ -154,8 +164,7 @@ let handle_command t (header, payload) =
| _ ->
Ok (t, [ reply (`Vms vms) ], `End)
end
| `Vm_create vm_config ->
handle_create t header vm_config
| `Vm_create vm_config -> handle_create t reply id vm_config
| `Vm_force_create vm_config ->
begin
let resources =
@ -166,20 +175,20 @@ let handle_command t (header, payload) =
Vmm_resources.check_vm_policy resources id vm_config >>= function
| false -> Error (`Msg "wouldn't match policy")
| true -> match Vmm_resources.find_vm t.resources id with
| None -> handle_create t header vm_config
| None -> handle_create t reply id 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 header vm_config
| None -> handle_create t reply id 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
(task, fun t -> msg_to_err @@ handle_create t header vm_config))
(task, fun t -> msg_to_err @@ handle_create t reply id vm_config))
end
| `Vm_destroy ->
begin match Vmm_resources.find_vm t.resources id with
match Vmm_resources.find_vm t.resources id with
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = string_of_id id in
@ -192,8 +201,61 @@ let handle_command t (header, payload) =
let tasks = String.Map.remove id_str t.tasks in
Ok ({ t with tasks }, out, next)
| None -> Error (`Msg "destroy: not found")
let handle_block_cmd t reply id = function
| `Block_remove ->
Logs.debug (fun m -> m "removing block %a" pp_id id) ;
begin match Vmm_resources.find_block t.resources id with
| None -> Error (`Msg "remove block: not found")
| Some (_, true) -> Error (`Msg "remove block: is in use")
| Some (_, false) ->
Vmm_unix.destroy_block id >>= fun () ->
Vmm_resources.remove_block t.resources id >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "removed block") ], `End)
end
| `Block_add size ->
begin
Logs.debug (fun m -> m "insert block %a: %dMB" pp_id id size) ;
match Vmm_resources.find_block t.resources id with
| Some _ -> Error (`Msg "block device with same name already exists")
| None ->
Vmm_resources.check_block_policy t.resources id size >>= function
| false -> Error (`Msg "adding block device would violate policy")
| true ->
Vmm_unix.create_block id size >>= fun () ->
Vmm_resources.insert_block t.resources id size >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
end
| `Block_info ->
Logs.debug (fun m -> m "block %a" pp_id id) ;
let blocks =
Vmm_resources.fold t.resources id
(fun _ _ blocks -> blocks)
(fun _ _ blocks-> blocks)
(fun prefix size active blocks -> (prefix, size, active) :: blocks)
[]
in
match blocks with
| [] ->
Logs.debug (fun m -> m "block: couldn't find %a" pp_id id) ;
Error (`Msg "block: not found")
| _ ->
Ok (t, [ reply (`Blocks blocks) ], `End)
let handle_command t (header, payload) =
let msg_to_err = function
| Ok x -> x
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing command: %s" msg) ;
(t, [ `Data (header, `Failure msg) ], `End)
and reply x = `Data (header, `Success x)
and id = header.Vmm_commands.id
in
msg_to_err (
match payload with
| `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
| `Command (`Vm_cmd vc) -> handle_vm_cmd t reply id msg_to_err vc
| `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
| _ ->
Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
Error (`Msg "unknown command"))